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

6
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,7 +301,10 @@ algoW = \case
-- | Unify two types producing a new substitution
unify :: Type -> Type -> Infer Subst
unify t0 t1 = case (t0, t1) of
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)

79
src/TypeChecker/TypeCheckerIr.hs
View file

@ -7,19 +7,25 @@ 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.Abs (
Data (..),
Ident (..),
Init (..),
Literal (..),
Type (..),
)
import Grammar.Print
import Prelude
import qualified Prelude as C (Eq, Ord, Read, Show)
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}
data Env = Env { count :: Int
data Env = Env
{ count :: Int
, sigs :: Map Ident Type
, constructors :: Map Ident Type
}
@ -65,12 +71,16 @@ 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 i (Bind (t, name) rhs) =
prPrec i 0 $
concatD
[ prt 0 name
, doc $ showString ":"
, prt 1 t
, prt 0 t
, doc $ showString "\n"
, prt 0 name
, doc $ showString "="
, prt 2 rhs
, prt 0 rhs
]
instance Print [Bind] where
@ -82,14 +92,18 @@ 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
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
prtIdP i (name, t) =
prPrec i 0 $
concatD
[ doc $ showString "("
, prt 0 name
, doc $ showString ":"
@ -97,37 +111,62 @@ prtIdP i (name, t) = prPrec i 0 $ concatD
, 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
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
EApp _ e1 e2 ->
prPrec i 2 $
concatD
[ prt 2 e1
, prt 3 e2
]
EAdd t e1 e2 -> prPrec i 1 $ concatD
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
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])
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
@ -137,7 +176,3 @@ instance Print [Inj] where
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]

14
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,7 +87,7 @@ 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 "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x")
@ -95,10 +96,15 @@ 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