Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

added new test and found another bug

Browse source
This commit is contained in:
sebastianselander 2023-03-06 16:25:03 +01:00
parent 6947614fba
commit eef6fa7668
5 changed files with 210 additions and 124 deletions
Download patch file Download diff file Expand all files Collapse all files

7
sample-programs/basic-5
View file

@ -2,7 +2,7 @@
-- double n = n + n;
apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
apply f x = \y. f x y ;
apply f x y = f x y ;
id : 'a -> 'a ;
id x = x ;
@ -11,4 +11,7 @@ add : _Int -> _Int -> _Int ;
add x y = x + y ;
main : _Int -> _Int -> _Int ;
main = (id add) 1 2 ;
main = apply (id add) ;
idadd : _Int -> _Int -> _Int ;
idadd = id add ;

38
src/TypeChecker/Bugs.md
View file

@ -2,6 +2,44 @@
None known at this moment
main\_bug should not typecheck
```hs
apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
apply f x = \y. f x y ;
id : 'a -> 'a ;
id x = x ;
add : _Int -> _Int -> _Int ;
add x y = x + y ;
main_bug : _Int -> _Int -> _Int ;
main_bug= (apply id) add ;
idadd : _Int -> _Int -> _Int ;
idadd = id add ;
```
main\_bug should typecheck
```hs
apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
apply f x = \y. f x y ;
id : 'a -> 'a ;
id x = x ;
add : _Int -> _Int -> _Int ;
add x y = x + y ;
main_bug : _Int -> _Int -> _Int ;
main_bug = apply (id add) ;
idadd : _Int -> _Int -> _Int ;
idadd = id add ;
```
## Fixed bugs
* 1

80
src/TypeChecker/TypeChecker.hs
View file

@ -14,6 +14,7 @@ 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 Grammar.Abs
import Grammar.Print (printTree)
import TypeChecker.TypeCheckerIr (
@ -300,38 +301,41 @@ algoW = \case
-- | Unify two types producing a new substitution
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"
-- \| TODO: Figure out a cleaner way to express the same thing
(TConstr (Constr name t), TConstr (Constr name' t')) ->
if name == name' && length t == length t'
then do
xs <- zipWithM unify t t'
return $ foldr compose nullSubst xs
else
throwError $
unwords
[ "Type constructor:"
, printTree name
, "(" ++ printTree t ++ ")"
, "does not match with:"
, printTree name'
, "(" ++ printTree t' ++ ")"
]
(a, b) ->
throwError . unwords $
[ "Type:"
, printTree a
, "can't be unified with:"
, printTree b
]
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
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"
-- \| TODO: Figure out a cleaner way to express the same thing
(TConstr (Constr name t), TConstr (Constr name' t')) ->
if name == name' && length t == length t'
then do
xs <- zipWithM unify t t'
return $ foldr compose nullSubst xs
else
throwError $
unwords
[ "Type constructor:"
, printTree name
, "(" ++ printTree t ++ ")"
, "does not match with:"
, printTree name'
, "(" ++ printTree t' ++ ")"
]
(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
@ -409,7 +413,7 @@ instance FreeVars (Map Ident Poly) where
-- | Apply substitutions to the environment.
applySt :: Subst -> Infer a -> Infer a
applySt s = local (\st -> st {vars = apply s (vars st)})
applySt s = local (\st -> st{vars = apply s (vars st)})
-- | Represents the empty substition set
nullSubst :: Subst
@ -419,21 +423,21 @@ nullSubst = M.empty
fresh :: Infer Type
fresh = do
n <- gets count
modify (\st -> st {count = n + 1})
modify (\st -> st{count = n + 1})
return . TPol . Ident $ 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)})
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)})
insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)})
-- | Insert a constructor with its data type
insertConstr :: Ident -> Type -> Infer ()
insertConstr i t =
modify (\st -> st {constructors = M.insert i t (constructors st)})
modify (\st -> st{constructors = M.insert i t (constructors st)})
-------- PATTERN MATCHING ---------
@ -441,7 +445,7 @@ 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)
(_, 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)

193
src/TypeChecker/TypeCheckerIr.hs
View file

@ -2,27 +2,33 @@
module TypeChecker.TypeCheckerIr where
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor.Identity (Identity)
import Data.Map (Map)
import Grammar.Abs (Data (..), Ident (..), Init (..),
Literal (..), Type (..))
import Grammar.Print
import Prelude
import qualified Prelude as C (Eq, Ord, Read, Show)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor.Identity (Identity)
import Data.Map (Map)
import Grammar.Abs (
Data (..),
Ident (..),
Init (..),
Literal (..),
Type (..),
)
import Grammar.Print
import Prelude
import Prelude qualified as C (Eq, Ord, Read, Show)
-- | A data type representing type variables
data Poly = Forall [Ident] Type
deriving Show
deriving (Show)
newtype Ctx = Ctx { vars :: Map Ident Poly }
newtype Ctx = Ctx {vars :: Map Ident Poly}
data Env = Env { count :: Int
, sigs :: Map Ident Type
, constructors :: Map Ident Type
}
data Env = Env
{ count :: Int
, sigs :: Map Ident Type
, constructors :: Map Ident Type
}
type Error = String
type Subst = Map Ident Type
@ -30,17 +36,17 @@ type Subst = Map Ident Type
type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
newtype Program = Program [Def]
deriving (C.Eq, C.Ord, C.Show, C.Read)
deriving (C.Eq, C.Ord, C.Show, C.Read)
data Exp
= EId Id
= EId Id
| ELit Type Literal
| ELet Bind Exp
| EApp Type Exp Exp
| EAdd Type Exp Exp
| EAbs Type Id Exp
| ECase Type Exp [Inj]
deriving (C.Eq, C.Ord, C.Read, C.Show)
deriving (C.Eq, C.Ord, C.Read, C.Show)
data Inj = Inj (Init, Type) Exp
deriving (C.Eq, C.Ord, C.Read, C.Show)
@ -54,90 +60,119 @@ data Bind = Bind Id Exp
deriving (C.Eq, C.Ord, C.Show, C.Read)
instance Print [Def] where
prt _ [] = concatD []
prt _ (x:xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
prt _ [] = concatD []
prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
instance Print Def where
prt i (DBind bind) = prt i bind
prt i (DData d) = prt i d
prt i (DBind bind) = prt i bind
prt i (DData d) = prt i d
instance Print Program where
prt i (Program sc) = prPrec i 0 $ prt 0 sc
instance Print Bind where
prt i (Bind (t, name) rhs) = prPrec i 0 $ concatD
[ prt 0 name
, doc $ showString ":"
, prt 1 t
, doc $ showString "="
, prt 2 rhs
]
prt i (Bind (t, name) rhs) =
prPrec i 0 $
concatD
[ prt 0 name
, doc $ showString ":"
, prt 0 t
, doc $ showString "\n"
, prt 0 name
, 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 ";"), doc (showString "\n"), prt 0 xs]
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), 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
]
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 ")"
]
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
prt i = \case
EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
ELet bs e ->
prPrec i 3 $
concatD
[ doc $ showString "let"
, prt 0 bs
, doc $ showString "in"
, prt 0 e
, doc $ showString "\n"
]
EApp _ 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
]
ECase t exp injs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 injs, doc (showString "}"), doc (showString ":"), prt 0 t])
EApp _ 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
, doc $ showString "\n"
]
EAbs t n e ->
prPrec i 0 $
concatD
[ doc $ showString "@"
, prt 0 t
, doc $ showString "\\"
, prtId 0 n
, doc $ showString "."
, prt 0 e
, doc $ showString "\n"
]
ECase t exp injs ->
prPrec
i
0
( concatD
[ doc (showString "case")
, prt 0 exp
, doc (showString "of")
, doc (showString "{")
, prt 0 injs
, doc (showString "}")
, doc (showString ":")
, prt 0 t
, doc $ showString "\n"
]
)
instance Print Inj where
prt i = \case
Inj (init,t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
prt i = \case
Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
instance Print [Inj] where
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]

16
tests/Tests.hs
View file

@ -29,6 +29,7 @@ main = hspec $ do
infer_eid
infer_eabs
infer_eapp
test_id_function
infer_elit = describe "algoW used on ELit" $ do
it "infers the type mono Int" $ do
@ -86,19 +87,24 @@ infer_eapp = describe "algoW used on EApp" $ do
let env = Env 0 mempty mempty
let t = Forall [] (TPol "a")
let ctx = Ctx (M.singleton (Ident (x :: String)) t)
getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed"
getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldSatisfy` isLeft
churf_id :: Bind
churf_id :: Bind
churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x")
churf_add :: Bind
churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y"))
churf_main :: Bind
churf_main = Bind "main" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "main" [] (EApp (EId "id") (EId "add"))
churf_main = Bind "main" (TArr (TMono "Int") (TMono "Int")) "main" [] (EApp (EApp (EId "id") (EId "add")) (ELit (LInt 0)))
test_bug :: IO ()
test_bug = undefined
prg = Program [DBind churf_main, DBind churf_add, DBind churf_id]
test_id_function :: SpecWith ()
test_id_function =
describe "typechecking a program with id, add and main, where id is applied to add in main" $ do
it "should succeed to find the correct type" $ do
typecheck prg `shouldSatisfy` isRight
isArrowPolyToMono :: Either Error Type -> Bool
isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True