source: sizechecking_branches/LL.hs @ 18

{-# Language GADTs,
        FlexibleInstances,
        FlexibleContexts,
        ScopedTypeVariables,
        TypeFamilies,
        NoMonomorphismRestriction,
        OverlappingInstances #-}
module LL where

import Data.Char
import Control.Monad.Instances()

data OpName = PLUS | MINUS | MUL
data Bottom = Bottom
  deriving Show


class Lambda l where
    type Arr l (a :: *) (b :: *) :: *
    labs    :: (l a -> l b) -> l (Arr l a b)
    app     :: l (Arr l a b) -> l a -> l b
    lit     :: Int -> l Int
    op      :: l Int -> OpName -> l Int -> l Int

-- Required for Num
instance Lambda l => Show (l a) where
    showsPrec _ _ = error "Error: no show"

-- Required for Num
instance Lambda l => Eq (l a) where
    (==) _ _ = error "Error: no eq"

instance Lambda l => Num (l Int) where
    fromInteger = lit . fromIntegral
    lhs + rhs   = op lhs PLUS rhs
    lhs - rhs   = op lhs MINUS rhs
    lhs * rhs   = op lhs MUL rhs
    abs = error "abs is not implemented"
    signum = error "signum is not implemented"

{- Printing -}
showVar x = if x>28 
    then showVar (x `div` 29) . showChar (chr $ ord 'a' + (x `mod` 29))
    else showChar $ chr $ ord 'a' + x

getPrec :: OpName -> (Int,Int,Int,Char)
getPrec PLUS = (4,4,5,'+')
getPrec MINUS = (4,4,5,'-')
getPrec MUL = (5,5,6,'*')

newtype LPrint a = LPrint { unPrint :: Int -> Int -> ShowS }

instance Lambda LPrint where
  type Arr LPrint a b = a -> b
  lit x      = LPrint $ \_ -> return $ shows x
  op m opc n = LPrint $ \p -> do
    let (prec, lprec, rprec, c) = getPrec opc
    l1 <- unPrint m lprec
    l2 <- unPrint n rprec
    return $ showParen (p>prec) $  l1 . showChar c . l2
  app f v    = LPrint $ \p -> do
    l1 <- unPrint f 6
    l2 <- unPrint v 7
    return $ showParen (p>6) $ l1 . showChar ' ' . l2
  labs e      = LPrint $ \p v -> let
    var = LPrint $ \_ -> return $ showVar v
    l = unPrint (e var) 0 $ succ v
    in showParen (p>0) $ showChar 'λ' . showVar v . showChar '.' . l

instance Show (LPrint a) where
    showsPrec _ e = unPrint e 0 0

view :: LPrint a -> LPrint a
view = id

{- Evaluating -}
newtype R a = R { unR :: a }

instance Lambda R where
  type Arr R a b = R a -> R b
  labs        = R
  app         = unR
  lit         = R
  op e1 op e2 = let opm = case op of
                                  PLUS  -> (+)
                                  MINUS -> (-)
                                  MUL   -> (*)
                in R $ opm (unR e1) (unR e2)

newtype RList a = RList { unList :: (Int, Int -> a)  }

instance (Show a) => Show (RList a) where
  show (RList (s,f)) = show (map f [0..s-1])

eval = unR

z = labs (\s -> s + lit 1) `app` (lit 1 + 2)