Incorporated most of main, as well as started on quickcheck
This commit is contained in:
sebastianselander
parent
06e65de235
commit
2f45f39435
19 changed files with 1252 additions and 1090 deletions
|
|
@ -1,238 +0,0 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Use traverse_" #-}
|
||||
|
||||
module TypeChecker.AlgoW where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor (bimap, second)
|
||||
import Data.Functor.Identity (Identity, runIdentity)
|
||||
import Data.List (foldl', intersect)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Grammar.Abs
|
||||
import Grammar.Print (Print, printTree)
|
||||
import qualified TypeChecker.HMIr as T
|
||||
|
||||
-- | A data type representing type variables
|
||||
data Poly = Forall [Ident] Type
|
||||
deriving Show
|
||||
|
||||
newtype Ctx = Ctx { vars :: Map Ident Poly }
|
||||
|
||||
data Env = Env { count :: Int
|
||||
, sigs :: Map Ident Type
|
||||
}
|
||||
|
||||
type Error = String
|
||||
type Subst = Map Ident Type
|
||||
|
||||
type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
|
||||
|
||||
initCtx = Ctx mempty
|
||||
initEnv = Env 0 mempty
|
||||
|
||||
runPretty :: Print a => Infer a -> Either Error String
|
||||
runPretty = fmap printTree . run
|
||||
|
||||
run :: Infer a -> Either Error a
|
||||
run = runC initEnv initCtx
|
||||
|
||||
runC :: Env -> Ctx -> Infer a -> Either Error a
|
||||
runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
|
||||
|
||||
typecheck :: Program -> Either Error T.Program
|
||||
typecheck = run . checkPrg
|
||||
|
||||
checkPrg :: Program -> Infer T.Program
|
||||
checkPrg (Program bs) = do
|
||||
traverse (\(Bind n t _ _ _) -> insertSig n t) bs
|
||||
bs' <- mapM checkBind bs
|
||||
return $ T.Program bs'
|
||||
|
||||
checkBind :: Bind -> Infer T.Bind
|
||||
checkBind (Bind n t _ args e) = do
|
||||
(t', e') <- inferExp $ makeLambda e (reverse args)
|
||||
s <- unify t t'
|
||||
let t'' = apply s t
|
||||
return $ T.Bind (t'',n) [] e'
|
||||
where
|
||||
makeLambda :: Exp -> [Ident] -> Exp
|
||||
makeLambda = foldl (flip EAbs)
|
||||
|
||||
inferExp :: Exp -> Infer (Type, T.Exp)
|
||||
inferExp e = do
|
||||
(s, t, e') <- w e
|
||||
let subbed = apply s t
|
||||
return (subbed, replace subbed e')
|
||||
|
||||
replace :: Type -> T.Exp -> T.Exp
|
||||
replace t = \case
|
||||
T.EInt t' e -> T.EInt t e
|
||||
T.EId t' i -> T.EId t i
|
||||
T.EAbs t' name e -> T.EAbs t name e
|
||||
T.EApp t' e1 e2 -> T.EApp t e1 e2
|
||||
T.EAdd t' e1 e2 -> T.EAdd t e1 e2
|
||||
T.ELet t' name e1 e2 -> T.ELet t name e1 e2
|
||||
|
||||
w :: Exp -> Infer (Subst, Type, T.Exp)
|
||||
w = \case
|
||||
EAnn e t -> do
|
||||
(s1, t', e') <- w e
|
||||
applySt s1 $ do
|
||||
s2 <- unify (apply s1 t) t'
|
||||
return (s2 `compose` s1, t, e')
|
||||
EInt n -> return (nullSubst, TMono "Int", T.EInt (TMono "Int") n)
|
||||
EId i -> do
|
||||
var <- asks vars
|
||||
case M.lookup i var of
|
||||
Nothing -> throwError $ "Unbound variable: " ++ show i
|
||||
Just t -> inst t >>= \x -> return (nullSubst, x, T.EId x i)
|
||||
EAbs name e -> do
|
||||
fr <- fresh
|
||||
withBinding name (Forall [] fr) $ do
|
||||
(s1, t', e') <- w e
|
||||
let newArr = TArr (apply s1 fr) t'
|
||||
return (s1, newArr, T.EAbs newArr name e')
|
||||
EAdd e0 e1 -> do
|
||||
(s1, t0, e0') <- w e0
|
||||
applySt s1 $ do
|
||||
(s2, t1, e1') <- w e1
|
||||
applySt s2 $ do
|
||||
s3 <- unify (subst s2 t0) (TMono "Int")
|
||||
s4 <- unify (subst s3 t1) (TMono "Int")
|
||||
return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
|
||||
EApp e0 e1 -> do
|
||||
fr <- fresh
|
||||
(s1, t0, e0') <- w e0
|
||||
applySt s1 $ do
|
||||
(s2, t1, e1') <- w e1
|
||||
applySt s2 $ do
|
||||
s3 <- unify (subst s2 t0) (TArr t1 fr)
|
||||
let t = apply s3 fr
|
||||
return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1')
|
||||
ELet name e0 e1 -> do
|
||||
(s1, t1, e0') <- w e0
|
||||
env <- asks vars
|
||||
let t' = generalize (apply s1 env) t1
|
||||
withBinding name t' $ do
|
||||
(s2, t2, e1') <- w e1
|
||||
return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' )
|
||||
|
||||
-- | Unify two types producing a new substitution (constraint)
|
||||
unify :: Type -> Type -> Infer Subst
|
||||
unify t0 t1 = case (t0, t1) of
|
||||
(TArr a b, TArr c d) -> do
|
||||
s1 <- unify a c
|
||||
s2 <- unify (subst s1 b) (subst s1 c)
|
||||
return $ s1 `compose` s2
|
||||
(TPol a, b) -> occurs a b
|
||||
(a, TPol b) -> occurs b a
|
||||
(TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
|
||||
(a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
|
||||
|
||||
-- | Check if a type is contained in another type.
|
||||
-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
|
||||
occurs :: Ident -> Type -> Infer Subst
|
||||
occurs i (TPol a) = return nullSubst
|
||||
occurs i t = if S.member i (free t)
|
||||
then throwError "Occurs check failed"
|
||||
else return $ M.singleton i t
|
||||
|
||||
-- | Generalize a type over all free variables in the substitution set
|
||||
generalize :: Map Ident Poly -> Type -> Poly
|
||||
generalize env t = Forall (S.toList $ free t S.\\ free env) t
|
||||
|
||||
-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
|
||||
inst :: Poly -> Infer Type
|
||||
inst (Forall xs t) = do
|
||||
xs' <- mapM (const fresh) xs
|
||||
let s = M.fromList $ zip xs xs'
|
||||
return $ apply s t
|
||||
|
||||
compose :: Subst -> Subst -> Subst
|
||||
compose m1 m2 = M.map (subst m1) m2 `M.union` m1
|
||||
|
||||
-- | A class representing free variables functions
|
||||
class FreeVars t where
|
||||
-- | Get all free variables from t
|
||||
free :: t -> Set Ident
|
||||
-- | Apply a substitution to t
|
||||
apply :: Subst -> t -> t
|
||||
|
||||
instance FreeVars Type where
|
||||
free :: Type -> Set Ident
|
||||
free (TPol a) = S.singleton a
|
||||
free (TMono _) = mempty
|
||||
free (TArr a b) = free a `S.union` free b
|
||||
apply :: Subst -> Type -> Type
|
||||
apply sub t = do
|
||||
case t of
|
||||
TMono a -> TMono a
|
||||
TPol a -> case M.lookup a sub of
|
||||
Nothing -> TPol a
|
||||
Just t -> t
|
||||
TArr a b -> TArr (apply sub a) (apply sub b)
|
||||
|
||||
instance FreeVars Poly where
|
||||
free :: Poly -> Set Ident
|
||||
free (Forall xs t) = free t S.\\ S.fromList xs
|
||||
apply :: Subst -> Poly -> Poly
|
||||
apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
|
||||
|
||||
instance FreeVars (Map Ident Poly) where
|
||||
free :: Map Ident Poly -> Set Ident
|
||||
free m = foldl' S.union S.empty (map free $ M.elems m)
|
||||
apply :: Subst -> Map Ident Poly -> Map Ident Poly
|
||||
apply s = M.map (apply s)
|
||||
|
||||
applySt :: Subst -> Infer a -> Infer a
|
||||
applySt s = local (\st -> st { vars = apply s (vars st) })
|
||||
|
||||
-- | Represents the empty substition set
|
||||
nullSubst :: Subst
|
||||
nullSubst = M.empty
|
||||
|
||||
-- | Substitute type variables with their mappings from the substitution set.
|
||||
subst :: Subst -> Type -> Type
|
||||
subst m t = do
|
||||
case t of
|
||||
TPol a -> fromMaybe t (M.lookup a m)
|
||||
TMono a -> TMono a
|
||||
TArr a b -> TArr (subst m a) (subst m b)
|
||||
|
||||
-- | Generate a new fresh variable and increment the state counter
|
||||
fresh :: Infer Type
|
||||
fresh = do
|
||||
n <- gets count
|
||||
modify (\st -> st { count = n + 1 })
|
||||
return . TPol . Ident $ "t" ++ show n
|
||||
|
||||
-- | Run the monadic action with an additional binding
|
||||
withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
|
||||
withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
|
||||
|
||||
-- | Insert a function signature into the environment
|
||||
insertSig :: Ident -> Type -> Infer ()
|
||||
insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
|
||||
|
||||
-- | Lookup a variable in the context
|
||||
lookupVar :: Ident -> Infer Poly
|
||||
lookupVar i = do
|
||||
m <- asks vars
|
||||
case M.lookup i m of
|
||||
Just t -> return t
|
||||
Nothing -> throwError $ "Unbound variable: " ++ show i
|
||||
|
||||
lett = let (Right (t,e)) = run $ inferExp $ ELet "x" (EAdd (EInt 5) (EInt 5)) (EAdd (EId "x") (EId "x"))
|
||||
in t == TMono "Int"
|
||||
|
||||
letty = let (Right (t,e)) = run $ inferExp $ ELet "f" (EAbs "x" (EId "x")) (EApp (EId "f") (EInt 3))
|
||||
in e
|
||||
|
|
@ -1,181 +0,0 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Use traverse_" #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module TypeChecker.HM where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor (bimap, second)
|
||||
import Data.Functor.Identity (Identity, runIdentity)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Grammar.Abs
|
||||
import Grammar.Print
|
||||
import qualified TypeChecker.HMIr as T
|
||||
|
||||
type Infer = StateT Ctx (ExceptT String Identity)
|
||||
type Error = String
|
||||
|
||||
data Ctx = Ctx { constr :: Map Type Type
|
||||
, vars :: Map Ident Type
|
||||
, sigs :: Map Ident Type
|
||||
, frsh :: Char }
|
||||
deriving Show
|
||||
|
||||
runC :: Ctx -> Infer a -> Either String (a, Ctx)
|
||||
runC c = runIdentity . runExceptT . flip runStateT c
|
||||
|
||||
run :: Infer a -> Either String a
|
||||
run = runIdentity . runExceptT . flip evalStateT initC
|
||||
|
||||
initC :: Ctx
|
||||
initC = Ctx M.empty M.empty M.empty 'a'
|
||||
|
||||
typecheck :: Program -> Either Error T.Program
|
||||
typecheck = run . inferPrg
|
||||
|
||||
inferPrg :: Program -> Infer T.Program
|
||||
inferPrg (Program bs) = do
|
||||
traverse (\(Bind n t _ _ _) -> insertSig n t) bs
|
||||
bs' <- mapM inferBind bs
|
||||
return $ T.Program bs'
|
||||
|
||||
inferBind :: Bind -> Infer T.Bind
|
||||
inferBind (Bind i t _ params rhs) = do
|
||||
(t',e') <- inferExp (makeLambda rhs (reverse params))
|
||||
when (t /= t') (throwError . unwords $ [ "Signature of function"
|
||||
, show i
|
||||
, "with type:"
|
||||
, show t
|
||||
, "does not match inferred type"
|
||||
, show t'
|
||||
, "of expression:"
|
||||
, show e'])
|
||||
return $ T.Bind (t,i) [] e'
|
||||
|
||||
makeLambda :: Exp -> [Ident] -> Exp
|
||||
makeLambda = foldl (flip EAbs)
|
||||
|
||||
inferExp :: Exp -> Infer (Type, T.Exp)
|
||||
inferExp e = do
|
||||
(t, e') <- inferExp' e
|
||||
t'' <- solveConstraints t
|
||||
return (t'', replaceType t'' e')
|
||||
|
||||
where
|
||||
inferExp' :: Exp -> Infer (Type, T.Exp)
|
||||
inferExp' = \case
|
||||
EAnn e t -> do
|
||||
(t',e') <- inferExp' e
|
||||
t'' <- solveConstraints t'
|
||||
when (t'' /= t) (throwError "Annotated type and inferred type don't match")
|
||||
return (t', e')
|
||||
EInt i -> return (int, T.EInt int i)
|
||||
EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
|
||||
EAdd e1 e2 -> do
|
||||
insertSig "+" (TArr int (TArr int int))
|
||||
inferExp' (EApp (EApp (EId "+") e1) e2)
|
||||
EApp e1 e2 -> do
|
||||
(t1, e1') <- inferExp' e1
|
||||
(t2, e2') <- inferExp' e2
|
||||
fr <- fresh
|
||||
addConstraint t1 (TArr t2 fr)
|
||||
return (fr, T.EApp fr e1' e2')
|
||||
EAbs name e -> do
|
||||
fr <- fresh
|
||||
insertVar name fr
|
||||
(ret_t,e') <- inferExp' e
|
||||
t <- solveConstraints (TArr fr ret_t)
|
||||
return (t, T.EAbs t name e')
|
||||
ELet name e1 e2 -> error "Let expression not implemented yet"
|
||||
|
||||
replaceType :: Type -> T.Exp -> T.Exp
|
||||
replaceType t = \case
|
||||
T.EInt _ i -> T.EInt t i
|
||||
T.EId _ i -> T.EId t i
|
||||
T.EAdd _ e1 e2 -> T.EAdd t e1 e2
|
||||
T.EApp _ e1 e2 -> T.EApp t e1 e2
|
||||
T.EAbs _ name e -> T.EAbs t name e
|
||||
T.ELet _ name e1 e2 -> T.ELet t name e1 e2
|
||||
|
||||
isInt :: Type -> Bool
|
||||
isInt (TMono "Int") = True
|
||||
isInt _ = False
|
||||
|
||||
lookupVar :: Ident -> Infer Type
|
||||
lookupVar i = do
|
||||
st <- get
|
||||
case M.lookup i (vars st) of
|
||||
Just t -> return t
|
||||
Nothing -> case M.lookup i (sigs st) of
|
||||
Just t -> return t
|
||||
Nothing -> throwError $ "Unbound variable or function" ++ printTree i
|
||||
|
||||
insertVar :: Ident -> Type -> Infer ()
|
||||
insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } )
|
||||
|
||||
insertSig :: Ident -> Type -> Infer ()
|
||||
insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } )
|
||||
|
||||
-- | Generate a new fresh variable and increment the state
|
||||
fresh :: Infer Type
|
||||
fresh = do
|
||||
chr <- gets frsh
|
||||
modify (\st -> st { frsh = succ chr })
|
||||
return $ TPol (Ident [chr])
|
||||
|
||||
-- | Adds a constraint to the constraint set.
|
||||
-- i.e: a = int -> b
|
||||
-- b = int
|
||||
-- thus when solving constraints it must be the case that
|
||||
-- a = int -> int
|
||||
addConstraint :: Type -> Type -> Infer ()
|
||||
addConstraint t1 t2 = do
|
||||
modify (\st -> st { constr = M.insert t1 t2 (constr st) })
|
||||
|
||||
-- | Given a type, solve the constraints and figure out the type that should be assigned to it.
|
||||
solveConstraints :: Type -> Infer Type
|
||||
solveConstraints t = do
|
||||
c <- gets constr
|
||||
v <- gets vars
|
||||
xs <- solveAll (M.toList c)
|
||||
modify (\st -> st { constr = M.fromList xs })
|
||||
return $ subst t xs
|
||||
|
||||
-- | Substitute
|
||||
subst :: Type -> [(Type, Type)] -> Type
|
||||
subst t [] = t
|
||||
subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
|
||||
subst t (x:xs) = subst (replace x t) xs
|
||||
|
||||
-- | Given a set of constraints run the replacement on all of them, producing a new set of
|
||||
-- replacements.
|
||||
-- https://youtu.be/trmq3wYcUxU - good video for explanation
|
||||
solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
|
||||
solveAll [] = return []
|
||||
solveAll (x:xs) = case x of
|
||||
(TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs
|
||||
(TArr t1 t2, b) -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs
|
||||
(a, TArr t1 t2) -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
|
||||
(TMono a, TPol b) -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
|
||||
(TPol a, TMono b) -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs
|
||||
(TPol a, TPol b) -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
|
||||
(TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types"
|
||||
|
||||
solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
|
||||
solve x = map (both (replace x))
|
||||
|
||||
-- | Given a constraint (type, type) and a type, if the constraint matches the input
|
||||
-- replace with the constrained type
|
||||
replace :: (Type, Type) -> Type -> Type
|
||||
replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
|
||||
replace (a,b) c = if a==c then b else c
|
||||
|
||||
both :: (a -> b) -> (a,a) -> (b,b)
|
||||
both f = bimap f f
|
||||
|
||||
int = TMono "Int"
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module TypeChecker.HMIr
|
||||
( module Grammar.Abs
|
||||
, module TypeChecker.HMIr
|
||||
) where
|
||||
|
||||
import Grammar.Abs (Ident (..), Type (..))
|
||||
import Grammar.Print
|
||||
import Prelude
|
||||
import qualified Prelude as C (Eq, Ord, Read, Show)
|
||||
|
||||
newtype Program = Program [Bind]
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
data Exp
|
||||
= EId Type Ident
|
||||
| EInt Type Integer
|
||||
| ELet Type Ident Exp Exp
|
||||
| EApp Type Exp Exp
|
||||
| EAdd Type Exp Exp
|
||||
| EAbs Type Ident Exp
|
||||
deriving (C.Eq, C.Ord, C.Read)
|
||||
|
||||
instance Show Exp where
|
||||
show (EId t (Ident i)) = i ++ " : " ++ show t
|
||||
show (EInt _ i) = show i
|
||||
show (ELet t i e1 e2) = "let " ++ show t ++ " = " ++ show e1 ++ " in " ++ show e2
|
||||
show (EApp t e1 e2) = show e1 ++ " " ++ show e2 ++ " : " ++ show t
|
||||
show (EAdd _ e1 e2) = show e1 ++ " + " ++ show e2
|
||||
show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t
|
||||
|
||||
type Id = (Type, Ident)
|
||||
|
||||
data Bind = Bind Id [Id] Exp
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
instance Print Program where
|
||||
prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||
|
||||
instance Print Bind where
|
||||
prt i (Bind name@(n, _) parms rhs) = prPrec i 0 $ concatD
|
||||
[ prtId 0 name
|
||||
, doc $ showString ";"
|
||||
, prt 0 n
|
||||
, prtIdPs 0 parms
|
||||
, doc $ showString "="
|
||||
, prt 0 rhs
|
||||
]
|
||||
|
||||
instance Print [Bind] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
||||
prtIdPs :: Int -> [Id] -> Doc
|
||||
prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
|
||||
|
||||
prtId :: Int -> Id -> Doc
|
||||
prtId i (name, t) = prPrec i 0 $ concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
]
|
||||
|
||||
prtIdP :: Int -> Id -> Doc
|
||||
prtIdP i (name, t) = prPrec i 0 $ concatD
|
||||
[ doc $ showString "("
|
||||
, prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, doc $ showString ")"
|
||||
]
|
||||
|
||||
|
||||
instance Print Exp where
|
||||
prt i = \case
|
||||
EId _ n -> prPrec i 3 $ concatD [prt 0 n]
|
||||
EInt _ i1 -> prPrec i 3 $ concatD [prt 0 i1]
|
||||
ELet _ name e1 e2 -> prPrec i 3 $ concatD
|
||||
[ doc $ showString "let"
|
||||
, prt 0 name
|
||||
, prt 0 e1
|
||||
, doc $ showString "in"
|
||||
, prt 0 e2
|
||||
]
|
||||
EApp t e1 e2 -> prPrec i 2 $ concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, prt 2 e1
|
||||
, prt 3 e2
|
||||
]
|
||||
EAdd t e1 e2 -> prPrec i 1 $ concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, prt 1 e1
|
||||
, doc $ showString "+"
|
||||
, prt 2 e2
|
||||
]
|
||||
EAbs t n e -> prPrec i 0 $ concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, doc $ showString "\\"
|
||||
, prt 0 n
|
||||
, doc $ showString "."
|
||||
, prt 0 e
|
||||
]
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,153 +1,250 @@
|
|||
-- {-# LANGUAGE LambdaCase #-}
|
||||
-- {-# LANGUAGE OverloadedRecordDot #-}
|
||||
-- {-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Use traverse_" #-}
|
||||
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
|
||||
|
||||
module TypeChecker.TypeChecker where
|
||||
|
||||
-- import Control.Monad (void)
|
||||
-- import Control.Monad.Except (ExceptT, runExceptT, throwError)
|
||||
-- import Control.Monad.State (StateT)
|
||||
-- import qualified Control.Monad.State as St
|
||||
-- import Data.Functor.Identity (Identity, runIdentity)
|
||||
-- import Data.Map (Map)
|
||||
-- import qualified Data.Map as M
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Functor.Identity (Identity, runIdentity)
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
|
||||
-- import TypeChecker.TypeCheckerIr
|
||||
import Grammar.Abs
|
||||
import Grammar.Print (printTree)
|
||||
import qualified TypeChecker.TypeCheckerIr as T
|
||||
|
||||
-- data Ctx = Ctx
|
||||
-- { vars :: Map Integer Type
|
||||
-- , sigs :: Map Ident Type
|
||||
-- , nextFresh :: Int
|
||||
-- }
|
||||
-- deriving (Show)
|
||||
-- | A data type representing type variables
|
||||
data Poly = Forall [Ident] Type
|
||||
deriving Show
|
||||
|
||||
-- -- Perhaps swap over to reader monad instead for vars and sigs.
|
||||
-- type Infer = StateT Ctx (ExceptT Error Identity)
|
||||
newtype Ctx = Ctx { vars :: Map Ident Poly }
|
||||
|
||||
-- {-
|
||||
data Env = Env { count :: Int
|
||||
, sigs :: Map Ident Type
|
||||
}
|
||||
|
||||
-- The type checker will assume we first rename all variables to unique name, as to not
|
||||
-- have to care about scoping. It significantly improves the quality of life of the
|
||||
-- programmer.
|
||||
type Error = String
|
||||
type Subst = Map Ident Type
|
||||
|
||||
-- TODOs:
|
||||
-- Add skolemization variables. i.e
|
||||
-- { \x. 3 : forall a. a -> a }
|
||||
-- should not type check
|
||||
type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
|
||||
|
||||
-- Generalize. Not really sure what that means though
|
||||
initCtx = Ctx mempty
|
||||
initEnv = Env 0 mempty
|
||||
|
||||
-- -}
|
||||
runPretty :: Exp -> Either Error String
|
||||
runPretty = fmap (printTree . fst). run . inferExp
|
||||
|
||||
-- typecheck :: RProgram -> Either Error TProgram
|
||||
-- typecheck = todo
|
||||
run :: Infer a -> Either Error a
|
||||
run = runC initEnv initCtx
|
||||
|
||||
-- run :: Infer a -> Either Error a
|
||||
-- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
|
||||
runC :: Env -> Ctx -> Infer a -> Either Error a
|
||||
runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e
|
||||
|
||||
-- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
|
||||
-- -- { \x. \y. x + y } will have the type { a -> b -> Int }
|
||||
-- inferExp :: RExp -> Infer Type
|
||||
-- inferExp = \case
|
||||
typecheck :: Program -> Either Error T.Program
|
||||
typecheck = run . checkPrg
|
||||
|
||||
-- RAnn expr typ -> do
|
||||
-- t <- inferExp expr
|
||||
-- void $ t =:= typ
|
||||
-- return t
|
||||
checkPrg :: Program -> Infer T.Program
|
||||
checkPrg (Program bs) = do
|
||||
let bs' = getBinds bs
|
||||
traverse (\(Bind n t _ _ _) -> insertSig n t) bs'
|
||||
bs' <- mapM checkBind bs'
|
||||
return $ T.Program bs'
|
||||
where
|
||||
getBinds :: [Def] -> [Bind]
|
||||
getBinds = map toBind . filter isBind
|
||||
isBind :: Def -> Bool
|
||||
isBind (DBind _) = True
|
||||
isBind _ = True
|
||||
toBind :: Def -> Bind
|
||||
toBind (DBind bind) = bind
|
||||
toBind _ = error "Can't convert DData to Bind"
|
||||
|
||||
-- RBound num name -> lookupVars num
|
||||
checkBind :: Bind -> Infer T.Bind
|
||||
checkBind (Bind n t _ args e) = do
|
||||
(t', e') <- inferExp $ makeLambda e (reverse args)
|
||||
s <- unify t t'
|
||||
let t'' = apply s t
|
||||
unless (t `typeEq` t'') (throwError $ unwords ["Top level signature", printTree t, "does not match body with type:", printTree t''])
|
||||
return $ T.Bind (n, t) [] e'
|
||||
where
|
||||
makeLambda :: Exp -> [Ident] -> Exp
|
||||
makeLambda = foldl (flip EAbs)
|
||||
|
||||
-- RFree name -> lookupSigs name
|
||||
typeEq :: Type -> Type -> Bool
|
||||
typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r'
|
||||
typeEq (TMono a) (TMono b) = a == b
|
||||
typeEq (TPol _) (TPol _) = True
|
||||
typeEq _ _ = False
|
||||
|
||||
-- RConst (CInt i) -> return $ TMono "Int"
|
||||
inferExp :: Exp -> Infer (Type, T.Exp)
|
||||
inferExp e = do
|
||||
(s, t, e') <- w e
|
||||
let subbed = apply s t
|
||||
return (subbed, replace subbed e')
|
||||
|
||||
-- RConst (CStr str) -> return $ TMono "Str"
|
||||
replace :: Type -> T.Exp -> T.Exp
|
||||
replace t = \case
|
||||
T.ELit _ e -> T.ELit t e
|
||||
T.EId (n, _) -> T.EId (n, t)
|
||||
T.EAbs _ name e -> T.EAbs t name e
|
||||
T.EApp _ e1 e2 -> T.EApp t e1 e2
|
||||
T.EAdd _ e1 e2 -> T.EAdd t e1 e2
|
||||
T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2
|
||||
|
||||
-- RAdd expr1 expr2 -> do
|
||||
-- let int = TMono "Int"
|
||||
-- typ1 <- check expr1 int
|
||||
-- typ2 <- check expr2 int
|
||||
-- return int
|
||||
w :: Exp -> Infer (Subst, Type, T.Exp)
|
||||
w = \case
|
||||
|
||||
-- RApp expr1 expr2 -> do
|
||||
-- fn_t <- inferExp expr1
|
||||
-- arg_t <- inferExp expr2
|
||||
-- res <- fresh
|
||||
-- new_t <- fn_t =:= TArrow arg_t res
|
||||
-- return res
|
||||
EAnn e t -> do
|
||||
(s1, t', e') <- w e
|
||||
applySt s1 $ do
|
||||
s2 <- unify (apply s1 t) t'
|
||||
return (s2 `compose` s1, t, e')
|
||||
|
||||
-- RAbs num name expr -> do
|
||||
-- arg <- fresh
|
||||
-- insertVars num arg
|
||||
-- typ <- inferExp expr
|
||||
-- return $ TArrow arg typ
|
||||
ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n))
|
||||
|
||||
-- check :: RExp -> Type -> Infer ()
|
||||
-- check e t = do
|
||||
-- t' <- inferExp e
|
||||
-- t =:= t'
|
||||
-- return ()
|
||||
ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a
|
||||
|
||||
-- fresh :: Infer Type
|
||||
-- fresh = do
|
||||
-- var <- St.gets nextFresh
|
||||
-- St.modify (\st -> st {nextFresh = succ var})
|
||||
-- return (TPoly $ Ident (show var))
|
||||
EId i -> do
|
||||
var <- asks vars
|
||||
case M.lookup i var of
|
||||
Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x))
|
||||
Nothing -> do
|
||||
sig <- gets sigs
|
||||
case M.lookup i sig of
|
||||
Nothing -> throwError $ "Unbound variable: " ++ show i
|
||||
Just t -> return (nullSubst, t, T.EId (i, t))
|
||||
|
||||
-- -- | Unify two types.
|
||||
-- (=:=) :: Type -> Type -> Infer Type
|
||||
-- (=:=) (TPoly _) b = return b
|
||||
-- (=:=) a (TPoly _) = return a
|
||||
-- (=:=) (TMono a) (TMono b) | a == b = return (TMono a)
|
||||
-- (=:=) (TArrow a b) (TArrow c d) = do
|
||||
-- t1 <- a =:= c
|
||||
-- t2 <- b =:= d
|
||||
-- return $ TArrow t1 t2
|
||||
-- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
|
||||
EAbs name e -> do
|
||||
fr <- fresh
|
||||
withBinding name (Forall [] fr) $ do
|
||||
(s1, t', e') <- w e
|
||||
let varType = apply s1 fr
|
||||
let newArr = TArr varType t'
|
||||
return (s1, newArr, T.EAbs newArr (name, varType) e')
|
||||
|
||||
-- lookupVars :: Integer -> Infer Type
|
||||
-- lookupVars i = do
|
||||
-- st <- St.gets vars
|
||||
-- case M.lookup i st of
|
||||
-- Just t -> return t
|
||||
-- Nothing -> throwError $ UnboundVar "lookupVars"
|
||||
EAdd e0 e1 -> do
|
||||
(s1, t0, e0') <- w e0
|
||||
applySt s1 $ do
|
||||
(s2, t1, e1') <- w e1
|
||||
applySt s2 $ do
|
||||
s3 <- unify (apply s2 t0) (TMono "Int")
|
||||
s4 <- unify (apply s3 t1) (TMono "Int")
|
||||
return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1')
|
||||
|
||||
-- insertVars :: Integer -> Type -> Infer ()
|
||||
-- insertVars i t = do
|
||||
-- st <- St.get
|
||||
-- St.put (st {vars = M.insert i t st.vars})
|
||||
EApp e0 e1 -> do
|
||||
fr <- fresh
|
||||
(s0, t0, e0') <- w e0
|
||||
applySt s0 $ do
|
||||
(s1, t1, e1') <- w e1
|
||||
-- applySt s1 $ do
|
||||
s2 <- unify (apply s1 t0) (TArr t1 fr)
|
||||
let t = apply s2 fr
|
||||
return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1')
|
||||
|
||||
-- lookupSigs :: Ident -> Infer Type
|
||||
-- lookupSigs i = do
|
||||
-- st <- St.gets sigs
|
||||
-- case M.lookup i st of
|
||||
-- Just t -> return t
|
||||
-- Nothing -> throwError $ UnboundVar "lookupSigs"
|
||||
ELet name e0 e1 -> do
|
||||
(s1, t1, e0') <- w e0
|
||||
env <- asks vars
|
||||
let t' = generalize (apply s1 env) t1
|
||||
withBinding name t' $ do
|
||||
(s2, t2, e1') <- w e1
|
||||
return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' )
|
||||
|
||||
-- insertSigs :: Ident -> Type -> Infer ()
|
||||
-- insertSigs i t = do
|
||||
-- st <- St.get
|
||||
-- St.put (st {sigs = M.insert i t st.sigs})
|
||||
ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b
|
||||
|
||||
-- {-# WARNING todo "TODO IN CODE" #-}
|
||||
-- todo :: a
|
||||
-- todo = error "TODO in code"
|
||||
-- | Unify two types producing a new substitution (constraint)
|
||||
unify :: Type -> Type -> Infer Subst
|
||||
unify t0 t1 = case (t0, t1) of
|
||||
(TArr a b, TArr c d) -> do
|
||||
s1 <- unify a c
|
||||
s2 <- unify (apply s1 b) (apply s1 d)
|
||||
return $ s1 `compose` s2
|
||||
(TPol a, b) -> occurs a b
|
||||
(a, TPol b) -> occurs b a
|
||||
(TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify"
|
||||
(a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b]
|
||||
|
||||
-- data Error
|
||||
-- = TypeMismatch String
|
||||
-- | NotNumber String
|
||||
-- | FunctionTypeMismatch String
|
||||
-- | NotFunction String
|
||||
-- | UnboundVar String
|
||||
-- | AnnotatedMismatch String
|
||||
-- | Default String
|
||||
-- deriving (Show)
|
||||
-- | Check if a type is contained in another type.
|
||||
-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal
|
||||
occurs :: Ident -> Type -> Infer Subst
|
||||
occurs _ (TPol _) = return nullSubst
|
||||
occurs i t = if S.member i (free t)
|
||||
then throwError "Occurs check failed"
|
||||
else return $ M.singleton i t
|
||||
|
||||
-- | Generalize a type over all free variables in the substitution set
|
||||
generalize :: Map Ident Poly -> Type -> Poly
|
||||
generalize env t = Forall (S.toList $ free t S.\\ free env) t
|
||||
|
||||
-- {-
|
||||
-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones.
|
||||
inst :: Poly -> Infer Type
|
||||
inst (Forall xs t) = do
|
||||
xs' <- mapM (const fresh) xs
|
||||
let s = M.fromList $ zip xs xs'
|
||||
return $ apply s t
|
||||
|
||||
-- The procedure inst(σ) specializes the polytype
|
||||
-- σ by copying the term and replacing the bound type variables
|
||||
-- consistently by new monotype variables.
|
||||
-- | Compose two substitution sets
|
||||
compose :: Subst -> Subst -> Subst
|
||||
compose m1 m2 = M.map (apply m1) m2 `M.union` m1
|
||||
|
||||
-- -}
|
||||
-- | A class representing free variables functions
|
||||
class FreeVars t where
|
||||
-- | Get all free variables from t
|
||||
free :: t -> Set Ident
|
||||
-- | Apply a substitution to t
|
||||
apply :: Subst -> t -> t
|
||||
|
||||
instance FreeVars Type where
|
||||
free :: Type -> Set Ident
|
||||
free (TPol a) = S.singleton a
|
||||
free (TMono _) = mempty
|
||||
free (TArr a b) = free a `S.union` free b
|
||||
apply :: Subst -> Type -> Type
|
||||
apply sub t = do
|
||||
case t of
|
||||
TMono a -> TMono a
|
||||
TPol a -> case M.lookup a sub of
|
||||
Nothing -> TPol a
|
||||
Just t -> t
|
||||
TArr a b -> TArr (apply sub a) (apply sub b)
|
||||
|
||||
instance FreeVars Poly where
|
||||
free :: Poly -> Set Ident
|
||||
free (Forall xs t) = free t S.\\ S.fromList xs
|
||||
apply :: Subst -> Poly -> Poly
|
||||
apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t)
|
||||
|
||||
instance FreeVars (Map Ident Poly) where
|
||||
free :: Map Ident Poly -> Set Ident
|
||||
free m = foldl' S.union S.empty (map free $ M.elems m)
|
||||
apply :: Subst -> Map Ident Poly -> Map Ident Poly
|
||||
apply s = M.map (apply s)
|
||||
|
||||
-- | Apply substitutions to the environment.
|
||||
applySt :: Subst -> Infer a -> Infer a
|
||||
applySt s = local (\st -> st { vars = apply s (vars st) })
|
||||
|
||||
-- | Represents the empty substition set
|
||||
nullSubst :: Subst
|
||||
nullSubst = M.empty
|
||||
|
||||
-- | Generate a new fresh variable and increment the state counter
|
||||
fresh :: Infer Type
|
||||
fresh = do
|
||||
n <- gets count
|
||||
modify (\st -> st { count = n + 1 })
|
||||
return . TPol . Ident $ "t" ++ show n
|
||||
|
||||
-- | Run the monadic action with an additional binding
|
||||
withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a
|
||||
withBinding i p = local (\st -> st { vars = M.insert i p (vars st) })
|
||||
|
||||
-- | Insert a function signature into the environment
|
||||
insertSig :: Ident -> Type -> Infer ()
|
||||
insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) })
|
||||
|
|
|
|||
|
|
@ -1,74 +1,99 @@
|
|||
-- {-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module TypeChecker.TypeCheckerIr --(
|
||||
-- TProgram (..),
|
||||
-- TBind (..),
|
||||
-- TExp (..),
|
||||
-- RProgram (..),
|
||||
-- RBind (..),
|
||||
-- RExp (..),
|
||||
-- Type (..),
|
||||
-- Const (..),
|
||||
-- Ident (..),
|
||||
-- ) where
|
||||
module TypeChecker.TypeCheckerIr
|
||||
( module Grammar.Abs
|
||||
, module TypeChecker.TypeCheckerIr
|
||||
) where
|
||||
|
||||
-- import Grammar.Print
|
||||
-- import Renamer.RenamerIr
|
||||
import Grammar.Abs (Ident (..), Literal (..), Type (..))
|
||||
import Grammar.Print
|
||||
import Prelude
|
||||
import qualified Prelude as C (Eq, Ord, Read, Show)
|
||||
|
||||
-- newtype TProgram = TProgram [TBind]
|
||||
-- deriving (Eq, Show, Read, Ord)
|
||||
newtype Program = Program [Bind]
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
-- data TBind = TBind Ident Type TExp
|
||||
-- deriving (Eq, Show, Read, Ord)
|
||||
data Exp
|
||||
= EId Id
|
||||
| ELit Type Literal
|
||||
| ELet Bind Exp
|
||||
| EApp Type Exp Exp
|
||||
| EAdd Type Exp Exp
|
||||
| EAbs Type Id Exp
|
||||
deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
|
||||
-- data TExp
|
||||
-- = TAnn TExp Type
|
||||
-- | TBound Integer Ident Type
|
||||
-- | TFree Ident Type
|
||||
-- | TConst Const Type
|
||||
-- | TApp TExp TExp Type
|
||||
-- | TAdd TExp TExp Type
|
||||
-- | TAbs Integer Ident TExp Type
|
||||
-- deriving (Eq, Ord, Show, Read)
|
||||
type Id = (Ident, Type)
|
||||
|
||||
data Bind = Bind Id [Id] Exp
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
instance Print Program where
|
||||
prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||
|
||||
instance Print Bind where
|
||||
prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, prtIdPs 0 parms
|
||||
, doc $ showString "="
|
||||
, prt 0 rhs
|
||||
]
|
||||
|
||||
instance Print [Bind] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
||||
prtIdPs :: Int -> [Id] -> Doc
|
||||
prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
|
||||
|
||||
prtId :: Int -> Id -> Doc
|
||||
prtId i (name, t) = prPrec i 0 $ concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
]
|
||||
|
||||
prtIdP :: Int -> Id -> Doc
|
||||
prtIdP i (name, t) = prPrec i 0 $ concatD
|
||||
[ doc $ showString "("
|
||||
, prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, doc $ showString ")"
|
||||
]
|
||||
|
||||
|
||||
instance Print Exp where
|
||||
prt i = \case
|
||||
EId n -> prPrec i 3 $ concatD [prtId 0 n]
|
||||
ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1]
|
||||
ELet bs e -> prPrec i 3 $ concatD
|
||||
[ doc $ showString "let"
|
||||
, prt 0 bs
|
||||
, doc $ showString "in"
|
||||
, prt 0 e
|
||||
]
|
||||
EApp t e1 e2 -> prPrec i 2 $ concatD
|
||||
[ prt 2 e1
|
||||
, prt 3 e2
|
||||
]
|
||||
EAdd t e1 e2 -> prPrec i 1 $ concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, prt 1 e1
|
||||
, doc $ showString "+"
|
||||
, prt 2 e2
|
||||
]
|
||||
EAbs t n e -> prPrec i 0 $ concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, doc $ showString "\\"
|
||||
, prtId 0 n
|
||||
, doc $ showString "."
|
||||
, prt 0 e
|
||||
]
|
||||
|
||||
-- instance Print TProgram where
|
||||
-- prt i = \case
|
||||
-- TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
|
||||
|
||||
-- instance Print TBind where
|
||||
-- prt i = \case
|
||||
-- TBind x t e ->
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ prt 0 x
|
||||
-- , doc (showString ":")
|
||||
-- , prt 0 t
|
||||
-- , doc (showString "=")
|
||||
-- , prt 0 e
|
||||
-- , doc (showString "\n")
|
||||
-- ]
|
||||
|
||||
-- instance Print TExp where
|
||||
-- prt i = \case
|
||||
-- TAnn e t ->
|
||||
-- prPrec i 2 $
|
||||
-- concatD
|
||||
-- [ prt 0 e
|
||||
-- , doc (showString ":")
|
||||
-- , prt 1 t
|
||||
-- ]
|
||||
-- TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
|
||||
-- TFree u t -> prPrec i 3 $ concatD [prt 0 u]
|
||||
-- TConst c _ -> prPrec i 3 (concatD [prt 0 c])
|
||||
-- TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
|
||||
-- TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
|
||||
-- TAbs _ u e t ->
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ doc (showString "(")
|
||||
-- , doc (showString "λ")
|
||||
-- , prt 0 u
|
||||
-- , doc (showString ".")
|
||||
-- , prt 0 e
|
||||
-- , doc (showString ")")
|
||||
-- ]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue