fixed Maybe ('a -> 'a) bug. Pattern matching still wonky, will have to redo
This commit is contained in:
sebastian
parent
fce54e7899
commit
62724964d7
3 changed files with 579 additions and 97 deletions
|
|
@ -9,12 +9,13 @@ import Control.Monad.Reader
|
|||
import Control.Monad.State
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Functor.Identity (runIdentity)
|
||||
import Debug.Trace (trace)
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as S
|
||||
import Debug.Trace (trace)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Grammar.Abs
|
||||
import Grammar.Print (printTree)
|
||||
import TypeChecker.TypeCheckerIr (
|
||||
|
|
@ -45,36 +46,23 @@ typecheck = run . checkPrg
|
|||
|
||||
{- | Start by freshening the type variable of data types to avoid clash with
|
||||
other user defined polymorphic types
|
||||
This might be wrong for type constructors that work over several variables
|
||||
-}
|
||||
freshenData :: Data -> Infer Data
|
||||
freshenData (Data (Constr name ts) constrs) = do
|
||||
fr <- fresh
|
||||
let fr' = case fr of
|
||||
TPol a -> a
|
||||
-- Meh, this part assumes fresh generates a polymorphic type
|
||||
_ ->
|
||||
error
|
||||
"Bug: implementation of \
|
||||
\ fresh and freshenData are not compatible"
|
||||
let new_ts = map (freshenType fr') ts
|
||||
let new_constrs = map (freshenConstr fr') constrs
|
||||
return $ Data (Constr name new_ts) new_constrs
|
||||
|
||||
let xs = (S.toList . free) =<< ts
|
||||
frs <- traverse (const fresh) xs
|
||||
let m = M.fromList $ zip xs frs
|
||||
return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs)
|
||||
|
||||
{- | Freshen all polymorphic variables, regardless of name
|
||||
| freshenType "d" (a -> b -> c) becomes (d -> d -> d)
|
||||
-}
|
||||
freshenType :: Ident -> Type -> Type
|
||||
freshenType iden = \case
|
||||
(TPol _) -> TPol iden
|
||||
(TArr a b) -> TArr (freshenType iden a) (freshenType iden b)
|
||||
(TConstr (Constr a ts)) ->
|
||||
TConstr (Constr a (map (freshenType iden) ts))
|
||||
rest -> rest
|
||||
|
||||
freshenConstr :: Ident -> Constructor -> Constructor
|
||||
freshenConstr iden (Constructor name t) =
|
||||
Constructor name (freshenType iden t)
|
||||
freshenType :: Map Ident Type -> Type -> Type
|
||||
freshenType m t = case t of
|
||||
TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m)
|
||||
TMono mono -> TMono mono
|
||||
TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2)
|
||||
TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts))
|
||||
|
||||
checkData :: Data -> Infer ()
|
||||
checkData d = do
|
||||
|
|
@ -108,7 +96,8 @@ retType a = a
|
|||
checkPrg :: Program -> Infer T.Program
|
||||
checkPrg (Program bs) = do
|
||||
preRun bs
|
||||
T.Program <$> checkDef bs
|
||||
bs' <- checkDef bs
|
||||
return $ T.Program bs'
|
||||
where
|
||||
preRun :: [Def] -> Infer ()
|
||||
preRun [] = return ()
|
||||
|
|
@ -122,7 +111,9 @@ checkPrg (Program bs) = do
|
|||
(DBind b) -> do
|
||||
b' <- checkBind b
|
||||
fmap (T.DBind b' :) (checkDef xs)
|
||||
(DData d) -> fmap (T.DData d :) (checkDef xs)
|
||||
(DData d) -> do
|
||||
d' <- freshenData d
|
||||
fmap (T.DData d' :) (checkDef xs)
|
||||
|
||||
checkBind :: Bind -> Infer T.Bind
|
||||
checkBind (Bind n t _ args e) = do
|
||||
|
|
@ -205,7 +196,8 @@ algoW = \case
|
|||
)
|
||||
applySt s1 $ do
|
||||
s2 <- unify t t'
|
||||
return (s2 `compose` s1, t, e')
|
||||
let composition = s2 `compose` s1
|
||||
return (composition, t, apply composition e')
|
||||
|
||||
-- \| ------------------
|
||||
-- \| Γ ⊢ i : Int, ∅
|
||||
|
|
@ -243,7 +235,7 @@ algoW = \case
|
|||
(s1, t', e') <- algoW e
|
||||
let varType = apply s1 fr
|
||||
let newArr = TArr varType t'
|
||||
return (s1, newArr, T.EAbs newArr (name, varType) e')
|
||||
return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e')
|
||||
|
||||
-- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁
|
||||
-- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int)
|
||||
|
|
@ -258,10 +250,11 @@ algoW = \case
|
|||
-- applySt s2 $ do
|
||||
s3 <- unify (apply s2 t0) (TMono "Int")
|
||||
s4 <- unify (apply s3 t1) (TMono "Int")
|
||||
let composition = s4 `compose` s3 `compose` s2 `compose` s1
|
||||
return
|
||||
( s4 `compose` s3 `compose` s2 `compose` s1
|
||||
( composition
|
||||
, TMono "Int"
|
||||
, T.EAdd (TMono "Int") e0' e1'
|
||||
, apply composition $ T.EAdd (TMono "Int") e0' e1'
|
||||
)
|
||||
|
||||
-- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1
|
||||
|
|
@ -277,7 +270,8 @@ algoW = \case
|
|||
-- 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')
|
||||
let composition = s2 `compose` s1 `compose` s0
|
||||
return (composition, t, apply composition $ T.EApp t e0' e1')
|
||||
|
||||
-- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁
|
||||
-- \| ----------------------------------------------
|
||||
|
|
@ -291,7 +285,9 @@ algoW = \case
|
|||
let t' = generalize (apply s1 env) t1
|
||||
withBinding name t' $ do
|
||||
(s2, t2, e1') <- algoW e1
|
||||
return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1')
|
||||
let composition = s2 `compose` s1
|
||||
return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
|
||||
|
||||
ECase caseExpr injs -> do
|
||||
(_, t0, e0') <- algoW caseExpr
|
||||
(injs', ts) <- mapAndUnzipM (checkInj t0) injs
|
||||
|
|
@ -299,15 +295,13 @@ algoW = \case
|
|||
[] -> throwError "Case expression missing any matches"
|
||||
ts -> do
|
||||
unified <- zipWithM unify ts (tail ts)
|
||||
let unified' = foldl' compose mempty unified
|
||||
let typ = apply unified' (head ts)
|
||||
return (unified', typ, T.ECase typ e0' injs')
|
||||
let composition = foldl' compose mempty unified
|
||||
let typ = apply composition (head ts)
|
||||
return (composition, typ, apply composition $ T.ECase typ e0' injs')
|
||||
|
||||
-- | Unify two types producing a new substitution
|
||||
unify :: Type -> Type -> Infer Subst
|
||||
unify t0 t1 = do
|
||||
trace ("t0: " ++ show t0) return ()
|
||||
trace ("t1: " ++ show t1) return ()
|
||||
case (t0, t1) of
|
||||
(TArr a b, TArr c d) -> do
|
||||
s1 <- unify a c
|
||||
|
|
@ -343,7 +337,7 @@ unify t0 t1 = do
|
|||
|
||||
{- | 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
|
||||
where these are equal
|
||||
-}
|
||||
occurs :: Ident -> Type -> Infer Subst
|
||||
occurs _ (TPol _) = return nullSubst
|
||||
|
|
@ -415,6 +409,30 @@ instance FreeVars (Map Ident Poly) where
|
|||
apply :: Subst -> Map Ident Poly -> Map Ident Poly
|
||||
apply s = M.map (apply s)
|
||||
|
||||
instance FreeVars T.Exp where
|
||||
free :: T.Exp -> Set Ident
|
||||
free = error "free not implemented for T.Exp"
|
||||
apply :: Subst -> T.Exp -> T.Exp
|
||||
apply s = \case
|
||||
T.EId (ident, t) -> T.EId (ident, apply s t)
|
||||
T.ELit t lit -> T.ELit (apply s t) lit
|
||||
T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2)
|
||||
T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2)
|
||||
T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2)
|
||||
T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e)
|
||||
T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs)
|
||||
|
||||
instance FreeVars T.Inj where
|
||||
free :: T.Inj -> Set Ident
|
||||
free = undefined
|
||||
apply :: Subst -> T.Inj -> T.Inj
|
||||
apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e)
|
||||
|
||||
instance FreeVars [T.Inj] where
|
||||
free :: [T.Inj] -> Set Ident
|
||||
free = foldl' (\acc x -> free x `S.union` acc) mempty
|
||||
apply s = map (apply s)
|
||||
|
||||
-- | Apply substitutions to the environment.
|
||||
applySt :: Subst -> Infer a -> Infer a
|
||||
applySt s = local (\st -> st{vars = apply s (vars st)})
|
||||
|
|
@ -449,23 +467,16 @@ insertConstr i t =
|
|||
checkInj :: Type -> Inj -> Infer (T.Inj, Type)
|
||||
checkInj caseType (Inj it expr) = do
|
||||
(args, t') <- initType caseType it
|
||||
(_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
|
||||
return (T.Inj (it, t') e', t)
|
||||
subst <- unify caseType t'
|
||||
applySt subst $ do
|
||||
(_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
|
||||
return (T.Inj (it, t') e', t)
|
||||
|
||||
initType :: Type -> Init -> Infer (Map Ident Poly, Type)
|
||||
initType expected = \case
|
||||
InitLit lit ->
|
||||
let returnType = litType lit
|
||||
in if expected == returnType
|
||||
then return (mempty, expected)
|
||||
else
|
||||
throwError $
|
||||
unwords
|
||||
[ "Inferred type"
|
||||
, printTree returnType
|
||||
, "does not match expected type:"
|
||||
, printTree expected
|
||||
]
|
||||
|
||||
InitLit lit -> error "Pattern match on literals not implemented yet"
|
||||
|
||||
InitConstr c args -> do
|
||||
st <- gets constructors
|
||||
case M.lookup c st of
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue