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

Add implicit foralls for bidir, update and unify pipeline

Browse source
This commit is contained in:
Martin Fredin 2023-04-03 17:34:33 +02:00
parent 12bca1c32d
commit 9870802371
33 changed files with 1010 additions and 1055 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Grammar.cf
View file

@ -75,8 +75,7 @@ PInj. Pattern ::= UIdent [Pattern1];
-- * AUX
-------------------------------------------------------------------------------
layout "of", "where", "let";
layout stop "in";
layout "of", "where";
layout toplevel;
separator Def ";";

219
Session.vim
View file

@ -1,219 +0,0 @@
let SessionLoad = 1
let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1
let v:this_session=expand("<sfile>:p")
silent only
silent tabonly
cd ~/Documents/bachelor_thesis/language
if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == ''
let s:wipebuf = bufnr('%')
endif
let s:shortmess_save = &shortmess
if &shortmess =~ 'A'
set shortmess=aoOA
else
set shortmess=aoO
endif
badd +1 ~/Documents/bachelor_thesis/language
badd +298 src/TypeChecker/TypeChecker.hs
badd +7 test_program
badd +46 src/TypeChecker/TypeCheckerIr.hs
badd +6 Grammar.cf
badd +1 src/Grammar/Abs.hs
argglobal
%argdel
$argadd ~/Documents/bachelor_thesis/language
set stal=2
tabnew +setlocal\ bufhidden=wipe
tabnew +setlocal\ bufhidden=wipe
tabnew +setlocal\ bufhidden=wipe
tabrewind
edit src/TypeChecker/TypeChecker.hs
let s:save_splitbelow = &splitbelow
let s:save_splitright = &splitright
set splitbelow splitright
wincmd _ | wincmd |
vsplit
1wincmd h
wincmd w
let &splitbelow = s:save_splitbelow
let &splitright = s:save_splitright
wincmd t
let s:save_winminheight = &winminheight
let s:save_winminwidth = &winminwidth
set winminheight=0
set winheight=1
set winminwidth=0
set winwidth=1
exe 'vert 1resize ' . ((&columns * 99 + 86) / 173)
exe 'vert 2resize ' . ((&columns * 73 + 86) / 173)
argglobal
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 298 - ((18 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 298
normal! 029|
lcd ~/Documents/bachelor_thesis/language
wincmd w
argglobal
if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/Grammar.cf", ":p")) | buffer ~/Documents/bachelor_thesis/language/Grammar.cf | else | edit ~/Documents/bachelor_thesis/language/Grammar.cf | endif
if &buftype ==# 'terminal'
silent file ~/Documents/bachelor_thesis/language/Grammar.cf
endif
balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 7 - ((6 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 7
normal! 0
lcd ~/Documents/bachelor_thesis/language
wincmd w
exe 'vert 1resize ' . ((&columns * 99 + 86) / 173)
exe 'vert 2resize ' . ((&columns * 73 + 86) / 173)
tabnext
edit ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs
let s:save_splitbelow = &splitbelow
let s:save_splitright = &splitright
set splitbelow splitright
wincmd _ | wincmd |
vsplit
1wincmd h
wincmd w
let &splitbelow = s:save_splitbelow
let &splitright = s:save_splitright
wincmd t
let s:save_winminheight = &winminheight
let s:save_winminwidth = &winminwidth
set winminheight=0
set winheight=1
set winminwidth=0
set winwidth=1
exe 'vert 1resize ' . ((&columns * 86 + 86) / 173)
exe 'vert 2resize ' . ((&columns * 86 + 86) / 173)
argglobal
balt ~/Documents/bachelor_thesis/language/test_program
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 1 - ((0 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 1
normal! 0
lcd ~/Documents/bachelor_thesis/language
wincmd w
argglobal
if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs", ":p")) | buffer ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | else | edit ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | endif
if &buftype ==# 'terminal'
silent file ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs
endif
balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 1 - ((0 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 1
normal! 0
lcd ~/Documents/bachelor_thesis/language
wincmd w
exe 'vert 1resize ' . ((&columns * 86 + 86) / 173)
exe 'vert 2resize ' . ((&columns * 86 + 86) / 173)
tabnext
edit ~/Documents/bachelor_thesis/language/Grammar.cf
argglobal
balt ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 40 - ((12 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 40
normal! 0
lcd ~/Documents/bachelor_thesis/language
tabnext
edit ~/Documents/bachelor_thesis/language/test_program
argglobal
balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs
setlocal fdm=manual
setlocal fde=0
setlocal fmr={{{,}}}
setlocal fdi=#
setlocal fdl=0
setlocal fml=1
setlocal fdn=20
setlocal fen
silent! normal! zE
let &fdl = &fdl
let s:l = 7 - ((6 * winheight(0) + 21) / 42)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 7
normal! 010|
lcd ~/Documents/bachelor_thesis/language
tabnext 1
set stal=1
if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal'
silent exe 'bwipe ' . s:wipebuf
endif
unlet! s:wipebuf
set winheight=1 winwidth=20
let &shortmess = s:shortmess_save
let s:sx = expand("<sfile>:p:r")."x.vim"
if filereadable(s:sx)
exe "source " . fnameescape(s:sx)
endif
let &g:so = s:so_save | let &g:siso = s:siso_save
set hlsearch
nohlsearch
doautoall SessionLoadPost
unlet SessionLoad
" vim: set ft=vim :

17
language.cabal
View file

@ -35,10 +35,12 @@ executable language
Auxiliary
Renamer.Renamer
TypeChecker.TypeChecker
AnnForall
TypeChecker.TypeCheckerHm
TypeChecker.TypeCheckerBidir
TypeChecker.TypeCheckerIr
TypeChecker.RemoveTEVar
TypeChecker.ReportTEVar
TypeChecker.RemoveForall
LambdaLifter
Monomorphizer.Monomorphizer
Monomorphizer.MonomorphizerIr
@ -72,11 +74,14 @@ executable language
Test-suite language-testsuite
type: exitcode-stdio-1.0
main-is: Tests.hs
main-is: Main.hs
other-modules:
TestTypeCheckerBidir
TestTypeCheckerHm
TestAnnForall
TestReportForall
TestRenamer
Grammar.Abs
Grammar.Lex
@ -90,13 +95,16 @@ Test-suite language-testsuite
Monomorphizer.MonomorphizerIr
Renamer.Renamer
TypeChecker.TypeChecker
AnnForall
ReportForall
TypeChecker.TypeCheckerHm
TypeChecker.TypeCheckerBidir
TypeChecker.RemoveTEVar
TypeChecker.ReportTEVar
TypeChecker.RemoveForall
TypeChecker.TypeCheckerIr
Compiler
hs-source-dirs: src, tests, tests/TypecheckingHM
hs-source-dirs: src, tests
build-depends:
base >=4.16
@ -110,6 +118,7 @@ Test-suite language-testsuite
, process
, bytestring
, hspec
, directory
default-language: GHC2021

27
pipeline.txt Normal file
View file

@ -0,0 +1,27 @@
Parser
|
ReportForall Report unnecessary foralls. Hm: report rank>2 foralls
|
AnnotateForall Annotate all unbound type variables with foralls
|
Renamer Rename type variables and term variables
|
/ \
/ \
TypeCheckHm TypeCheckBi
\ /
\ /
|
ReportTEVar Report type existential variables and change type AST
|
RemoveForall RemoveForall and change type AST
|
Monomorpher
|
Desugar
|
CodeGen

4
sample-programs/basic-0 → sample-programs/basic-0.crf
View file

@ -10,6 +10,10 @@ even : Int -> Bool ()
even x = not (odd x)
odd x = not (even x)
main = case even 64 of
True => 1
False => 0

18
sample-programs/basic-1.crf
View file

@ -1,9 +1,13 @@
data Bool () where {
True : Bool ()
data Bool () where
True : Bool ()
False : Bool ()
};
toBool = case 0 of {
0 => False;
_ => True;
};
toBool x = case x of
0 => False
_ => True
fromBool b = case b of
False => 0
True => 1
main = fromBool (toBool 10)

10
sample-programs/basic-10.crf Normal file
View file

@ -0,0 +1,10 @@
applyId : (forall a. a -> a) -> a -> a
applyId f x = f x
id : a -> a
id x = x
main = applyId id 4

14
sample-programs/basic-6.crf
View file

@ -1,10 +1,8 @@
data Bool () where {
True : Bool ()
data Bool () where
True : Bool ()
False : Bool ()
};
main : Bool () -> a -> Int ;
main b = case b of {
False => (\x. 1);
True => \x. 0;
};
main : Bool () -> a -> Int
main b = case b of
False => (\x. 1)
True => (\x. 0)

14
sample-programs/basic-7.crf
View file

@ -1,10 +1,8 @@
data Bool () where {
True : Bool ()
data Bool () where
True : Bool ()
False : Bool ()
};
ifThenElse : forall a. Bool () -> a -> a -> a;
ifThenElse b if else = case b of {
True => if;
False => else
}
ifThenElse : forall a. Bool () -> a -> a -> a
ifThenElse b if else = case b of
True => if
False => else

24
sample-programs/basic-8.crf
View file

@ -1,24 +1,20 @@
data Maybe (a) where {
data Maybe (a) where
Nothing : Maybe (a)
Just : a -> Maybe (a)
};
Just : a -> Maybe (a)
fromJust : Maybe (a) -> a ;
fromJust : Maybe (a) -> a
fromJust a =
case a of {
case a of
Just a => a
};
fromMaybe : a -> Maybe (a) -> a ;
fromMaybe : a -> Maybe (a) -> a
fromMaybe a b =
case b of {
Just a => a;
case b of
Just a => a
Nothing => a
};
maybe : b -> (a -> b) -> Maybe (a) -> b;
maybe : b -> (a -> b) -> Maybe (a) -> b
maybe b f ma =
case ma of {
Just a => f a;
case ma of
Just a => f a
Nothing => b
}

10
sample-programs/basic-9.crf
View file

@ -1,13 +1,9 @@
data List (a) where {
data List (a) where
Nil : List (a)
Cons : a -> List (a) -> List (a)
};
test xs = case xs of {
Cons Nil _ => 0 ;
};
test xs = case xs of
Cons Nil _ => 0
List a /= List (List a)

3
shell.nix
View file

@ -11,7 +11,8 @@ pkgs.haskellPackages.developPackage {
ghc
jasmin
llvmPackages_15.libllvm
texlive.combined.scheme-full
clang
# texlive.combined.scheme-full
])
++
(with pkgs.haskellPackages; [ cabal-install

100
src/AnnForall.hs Normal file
View file

@ -0,0 +1,100 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
module AnnForall (annotateForall) where
import Auxiliary (partitionDefs)
import Control.Applicative (Applicative (liftA2))
import Control.Monad.Except (throwError)
import Data.Function (on)
import Data.Set (Set)
import qualified Data.Set as Set
import Grammar.Abs
import Grammar.ErrM (Err)
annotateForall :: Program -> Err Program
annotateForall (Program defs) = do
ds' <- mapM (fmap DData . annData) ds
bs' <- mapM (fmap DBind . annBind) bs
pure $ Program (ds' ++ ss' ++ bs')
where
ss' = map (DSig . annSig) ss
(ds, ss, bs) = partitionDefs defs
annData :: Data -> Err Data
annData (Data typ injs) = do
(typ', tvars) <- annTyp typ
pure (Data typ' $ map (annInj tvars) injs)
where
annTyp typ = do
(bounded, ts) <- boundedTVars mempty typ
unbounded <- Set.fromList <$> mapM assertTVar ts
let diff = unbounded Set.\\ bounded
typ' = foldr TAll typ diff
(typ', ) . fst <$> boundedTVars mempty typ'
where
boundedTVars tvars typ = case typ of
TAll tvar t -> boundedTVars (Set.insert tvar tvars) t
TData _ ts -> pure (tvars, ts)
_ -> throwError "Misformed data declaration"
assertTVar typ = case typ of
TVar tvar -> pure tvar
_ -> throwError $ unwords [ "Misformed data declaration:"
, "Non type variable argument"
]
annInj tvars (Inj n t) =
Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars)
annSig :: Sig -> Sig
annSig (Sig name typ) = Sig name $ annType typ
annBind :: Bind -> Err Bind
annBind (Bind name vars exp) = Bind name vars <$> annExp exp
where
annExp = \case
EAnn e t -> flip EAnn (annType t) <$> annExp e
EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2)
EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2)
ELet bind e -> liftA2 ELet (annBind bind) (annExp e)
EAbs x e -> EAbs x <$> annExp e
ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs)
e -> pure e
annBranch (Branch p e) = Branch p <$> annExp e
annType :: Type -> Type
annType typ = go $ unboundedTVars typ
where
go us
| null us = typ
| otherwise = foldr TAll typ us
unboundedTVars :: Type -> Set TVar
unboundedTVars = unboundedTVars' mempty
unboundedTVars' :: Set TVar -> Type -> Set TVar
unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded
where
tvars = gatherTVars typ
gatherTVars = \case
TAll tvar t -> TVars { bounded = Set.singleton tvar
, unbounded = unboundedTVars' (Set.insert tvar bs) t
}
TVar tvar -> uTVars $ Set.singleton tvar
TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2
TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs
_ -> TVars { bounded = mempty, unbounded = mempty }
data TVars = TVars
{ bounded :: Set TVar
, unbounded :: Set TVar
} deriving (Eq, Show, Ord)
uTVars :: Set TVar -> TVars
uTVars us = TVars
{ bounded = mempty
, unbounded = us
}

28
src/Auxiliary.hs
View file

@ -1,14 +1,16 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Auxiliary (module Auxiliary) where
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Except (MonadError)
import Data.Either.Combinators (maybeToRight)
import Data.List (foldl')
import Grammar.Abs
import Prelude hiding ((>>), (>>=))
import Control.Applicative (Applicative (liftA2))
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Except (MonadError)
import Data.Either.Combinators (maybeToRight)
import Data.List (foldl')
import Grammar.Abs
import Prelude hiding ((>>), (>>=))
(>>) a b = a ++ " " ++ b
(>>=) a f = f a
@ -29,6 +31,9 @@ mapAccumM f = go
(acc'', xs') <- go acc' xs
pure (acc'', x' : xs')
onM :: Monad m => (b -> b -> c) -> (a -> m b) -> a -> a -> m c
onM f g x y = liftA2 f (g x) (g y)
unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 =
foldl'
@ -38,7 +43,7 @@ unzip4 =
([], [], [], [])
litType :: Lit -> Type
litType (LInt _) = int
litType (LInt _) = int
litType (LChar _) = char
int = TLit "Int"
@ -53,3 +58,10 @@ trd_ :: (a, b, c) -> c
snd_ (_, a, _) = a
fst_ (a, _, _) = a
trd_ (_, _, a) = a
partitionDefs :: [Def] -> ([Data], [Sig], [Bind])
partitionDefs defs = (datas, sigs, binds)
where
datas = [ d | DData d <- defs ]
sigs = [ s | DSig s <- defs ]
binds = [ b | DBind b <- defs ]

32
src/LambdaLifter.hs
View file

@ -178,27 +178,14 @@ abstractExp (free, (exp, typ)) = case exp of
names = snoc parm freeList
applyVars (e, t) name = (EApp (e, t) (EVar name, t_var), t_return)
where
(t_var, t_return) = applyVarType t
(t_var, t_return) = case t of
TFun t1 t2 -> (t1, t2)
abstractBranch :: AnnBranch -> State Int Branch
abstractBranch (_, AnnBranch patt exp) = Branch patt <$> abstractExp exp
applyVarType :: Type -> (Type, Type)
applyVarType typ = (t1, foldr ($) t2 foralls)
where
(t1, t2) = case typ' of
TFun t1 t2 -> (t1, t2)
_ -> error "Not a function!"
(foralls, typ') = skipForalls [] typ
skipForalls acc = \case
TAll tvar t -> skipForalls (snoc (TAll tvar) acc) t
t -> (acc, t)
nextNumber :: State Int Int
nextNumber = do
i <- get
@ -270,20 +257,9 @@ getVars :: Type -> [Type]
getVars = fst . partitionType
partitionType :: Type -> ([Type], Type)
partitionType = go [] . skipForalls'
partitionType = go []
where
go acc t = case t of
TFun t1 t2 -> go (snoc t1 acc) t2
_ -> (acc, t)
skipForalls' :: Type -> Type
skipForalls' = snd . skipForalls
skipForalls :: Type -> ([Type -> Type], Type)
skipForalls = go []
where
go acc typ = case typ of
TAll tvar t -> go (snoc (TAll tvar) acc) t
_ -> (acc, typ)

87
src/Main.hs
View file

@ -1,11 +1,12 @@
{-# LANGUAGE OverloadedRecordDot #-}
module Main where
import AnnForall (annotateForall)
import Codegen.Codegen (generateCode)
import Compiler (compile)
import Control.Monad (when)
import Data.Bool (bool)
import Control.Monad (when, (<=<))
import Data.List.Extra (isSuffixOf)
import Data.Maybe (fromJust, isNothing)
import Desugar.Desugar (desugar)
@ -13,10 +14,11 @@ import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Grammar.Print (Print, printTree)
import LambdaLifter (lambdaLift)
import Monomorphizer.Monomorphizer (monomorphize)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import System.Console.GetOpt (ArgDescr (NoArg, ReqArg),
ArgOrder (RequireOrder),
OptDescr (Option), getOpt,
@ -87,35 +89,40 @@ data Options = Options
}
main' :: Options -> String -> IO ()
main' opts s = do
main' opts s =
let
log :: (Print a, Show a) => a -> IO ()
log = printToErr . if opts.debug then show else printTree
in do
file <- readFile s
printToErr "-- Parse Tree -- "
parsed <- fromSyntaxErr . pProgram . resolveLayout True $ myLexer file
bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug
parsed <- fromErr . pProgram . resolveLayout True $ myLexer file
log parsed
printToErr "-- Desugar --"
let desugared = desugar parsed
bool (printToErr $ printTree desugared) (printToErr $ show desugared) opts.debug
log desugared
printToErr "\n-- Renamer --"
renamed <- fromRenamerErr . rename $ desugared
bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug
_ <- fromErr $ reportForall (fromJust opts.typechecker) desugared
renamed <- fromErr $ (rename <=< annotateForall) desugared
log renamed
printToErr "\n-- TypeChecker --"
typechecked <- fromTypeCheckerErr $ typecheck (fromJust opts.typechecker) renamed
bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug
typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed
log typechecked
printToErr "\n-- Lambda Lifter --"
let lifted = lambdaLift typechecked
bool (printToErr $ printTree lifted) (printToErr $ show lifted) opts.debug
log lifted
printToErr "\n -- Monomorphizer --"
let monomorphized = monomorphize lifted
bool (printToErr $ printTree monomorphized) (printToErr $ show monomorphized) opts.debug
log lifted
printToErr "\n -- Compiler --"
generatedCode <- fromCompilerErr $ generateCode monomorphized
generatedCode <- fromErr $ generateCode monomorphized
check <- doesPathExist "output"
when check (removeDirectoryRecursive "output")
@ -143,55 +150,9 @@ debugDotViz = do
spawnWait :: String -> IO ExitCode
spawnWait s = spawnCommand s >>= waitForProcess
printToErr :: String -> IO ()
printToErr = hPutStrLn stderr
fromCompilerErr :: Err a -> IO a
fromCompilerErr =
either
( \err -> do
putStrLn "\nCOMPILER ERROR"
putStrLn err
exitFailure
)
pure
fromSyntaxErr :: Err a -> IO a
fromSyntaxErr =
either
( \err -> do
putStrLn "\nSYNTAX ERROR"
putStrLn err
exitFailure
)
pure
fromTypeCheckerErr :: Err a -> IO a
fromTypeCheckerErr =
either
( \err -> do
putStrLn "\nTYPECHECKER ERROR"
putStrLn err
exitFailure
)
pure
fromRenamerErr :: Err a -> IO a
fromRenamerErr =
either
( \err -> do
putStrLn "\nRENAMER ERROR"
putStrLn err
exitFailure
)
pure
fromInterpreterErr :: Err a -> IO a
fromInterpreterErr =
either
( \err -> do
putStrLn "\nINTERPRETER ERROR"
putStrLn err
exitFailure
)
pure
fromErr :: Err a -> IO a
fromErr = either (\s -> printToErr s >> exitFailure) pure

65
src/Monomorphizer/Monomorphizer.hs
View file

@ -7,37 +7,40 @@
-- monomorphic bindings will be part of this compilation step.
-- Apply the following monomorphization function on all monomorphic binds, with
-- their type as an additional argument.
--
--
-- The function that transforms Binds operates on both monomorphic and
-- polymorphic functions, creates a context in which all possible polymorphic types
-- are mapped to concrete types, created using the additional argument.
-- Expressions are then recursively processed. The type of these expressions
-- are changed to using the mapped generic types. The expected type provided
-- in the recursion is changed depending on the different nodes.
--
--
-- When an external bind is encountered (with EId), it is checked whether it
-- exists in outputed binds or not. If it does, nothing further is evaluated.
-- If not, the bind transformer function is called on it with the
-- expected type in this context. The result of this computation (a monomorphic
-- expected type in this context. The result of this computation (a monomorphic
-- bind) is added to the resulting set of binds.
{-# LANGUAGE LambdaCase #-}
module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where
import qualified TypeChecker.TypeCheckerIr as T
import TypeChecker.TypeCheckerIr (Ident (Ident))
import qualified Monomorphizer.MorbIr as M
import Monomorphizer.DataTypeRemover (removeDataTypes)
import qualified Monomorphizer.MonomorphizerIr as O
import Monomorphizer.DataTypeRemover (removeDataTypes)
import qualified Monomorphizer.MorbIr as M
import qualified TypeChecker.TypeCheckerIr as T
import TypeChecker.TypeCheckerIr (Ident (Ident))
import Debug.Trace
import Control.Monad.State (MonadState (get), gets, modify, StateT (runStateT))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (fromJust)
import Control.Monad.Reader (Reader, MonadReader (local, ask), asks, runReader)
import Data.Coerce (coerce)
import Grammar.Print (printTree)
import Control.Monad.Reader (MonadReader (ask, local),
Reader, asks, runReader)
import Control.Monad.State (MonadState (get),
StateT (runStateT), gets,
modify)
import Data.Coerce (coerce)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Debug.Trace
import Grammar.Print (printTree)
-- | State Monad wrapper for "Env".
newtype EnvM a = EnvM (StateT Output (Reader Env) a)
@ -90,9 +93,9 @@ getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env))
mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)]
mapTypes (T.TLit _) (M.TLit _) = []
mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)]
mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++
mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++
mapTypes pt2 mt2
mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent
mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent
then error "nuh uh"
else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs)
mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'"
@ -111,8 +114,6 @@ getMonoFromPoly t = do env <- ask
Nothing -> M.TLit (Ident "void")
--error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps"
(T.TData ident args) -> M.TData ident (map (getMono polys) args)
-- TODO: TAll should work different/should not exist in this tree
(T.TAll _ t) -> getMono polys t
-- | If ident not already in env's output, morphed bind to output
-- (and all referenced binds within this bind).
@ -128,14 +129,14 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) =
bindMarked <- isBindMarked (coerce name')
-- Return with right name if already marked
if bindMarked then return name' else do
-- Mark so that this bind will not be processed in recursive or cyclic
-- Mark so that this bind will not be processed in recursive or cyclic
-- function calls
markBind (coerce name')
expt' <- getMonoFromPoly expt
exp' <- morphExp expt' exp
-- Get monomorphic type sof args
args' <- mapM convertArg args
addOutputBind $ M.Bind (coerce name', expectedType)
addOutputBind $ M.Bind (coerce name', expectedType)
args' (exp', expectedType)
return name'
@ -162,7 +163,7 @@ getInputData ident = do env <- ask
-- | Expects polymorphic types in data definition to be mapped
-- in environment.
--morphData :: T.Data -> EnvM ()
--morphData (T.Data t cs) = do
--morphData (T.Data t cs) = do
-- t' <- getMonoFromPoly t
-- output <- get
-- cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t
@ -170,7 +171,7 @@ getInputData ident = do env <- ask
-- addOutputData $ M.Data t' cs'
morphCons :: M.Type -> Ident -> EnvM ()
morphCons expectedType ident = do
morphCons expectedType ident = do
maybeD <- getInputData ident
case maybeD of
Nothing -> error $ "identifier '" ++ show ident ++ "' not found"
@ -191,7 +192,7 @@ morphCons expectedType ident = do
-- TODO: Change in tree so that these are the same.
-- Converts Lit
convertLit :: T.Lit -> M.Lit
convertLit (T.LInt v) = M.LInt v
convertLit (T.LInt v) = M.LInt v
convertLit (T.LChar v) = M.LChar v
morphExp :: M.Type -> T.Exp -> EnvM M.Exp
@ -204,7 +205,7 @@ morphExp expectedType exp = case exp of
morphApp M.EApp expectedType e1 e2
T.EAdd e1 e2 -> do
morphApp M.EAdd expectedType e1 e2
T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do
T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do
t' <- getMonoFromPoly t
morphExp t' exp
T.ECase (exp, t) bs -> do
@ -256,7 +257,7 @@ morphPattern ls = \case
-- | Creates a new identifier for a function with an assigned type
newFuncName :: M.Type -> T.Bind -> Ident
newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) =
newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) =
if bindName == "main"
then Ident bindName
else newName t ident
@ -286,7 +287,7 @@ runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env
-- | Creates the environment based on the input binds.
createEnv :: [T.Def] -> Env
createEnv defs = Env { input = Map.fromList bindPairs,
createEnv defs = Env { input = Map.fromList bindPairs,
dataDefs = Map.fromList dataPairs,
polys = Map.empty,
locals = Set.empty }
@ -312,7 +313,7 @@ getBindsFromDefs = foldl (\bs -> \case
getDefsFromOutput :: Output -> [M.Def]
getDefsFromOutput o =
map M.DBind binds ++
map M.DBind binds ++
(map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty)
where
(binds, dataInput) = splitBindsAndData o
@ -323,7 +324,7 @@ splitBindsAndData output = foldl
(\(oBinds, oData) (ident, o) -> case o of
Incomplete -> error "internal bug in monomorphizer"
Complete b -> (b:oBinds, oData)
Data t d -> (oBinds, (ident, t, d):oData))
Data t d -> (oBinds, (ident, t, d):oData))
([], [])
(Map.toList output)
@ -339,7 +340,7 @@ createNewData ((consIdent, consType, polyData):input) o =
newDataType = getDataType consType
newDataName = newName newDataType polyDataIdent
newCons = M.Inj consIdent consType
getDataType :: M.Type -> M.Type
getDataType (M.TFun t1 t2) = getDataType t2
getDataType tData@(M.TData _ _) = tData
@ -356,7 +357,7 @@ getDataType _ = error "???"
-- Nothing -> do
-- createNewData cs $ Map.insert ident (M.Data (M.TLit $ Ident "void") [newCons]) o
-- Just _ -> do
-- createNewData cs $ Map.adjust (\(M.Data _ pcs') ->
-- createNewData cs $ Map.adjust (\(M.Data _ pcs') ->
-- M.Data expectedType (newCons : pcs')) ident o
-- _ -> error "internal bug in monomorphizer"

298
src/Renamer/Renamer.hs
View file

@ -1,224 +1,112 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Renamer.Renamer (rename) where
import Auxiliary (mapAccumM)
import Control.Applicative (Applicative (liftA2))
import Control.Monad (when)
import Control.Monad.Except (
ExceptT,
MonadError (catchError, throwError),
runExceptT,
)
import Control.Monad.State (
MonadState,
State,
StateT,
evalState,
evalStateT,
get,
gets,
lift,
mapAndUnzipM,
modify,
put,
)
import Data.Function (on)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Tuple.Extra (dupe, second)
import Grammar.Abs
import Grammar.ErrM (Err)
import Grammar.Print (printTree)
import Auxiliary (maybeToRightM, onM, partitionDefs)
import Control.Applicative (liftA2)
import Control.Monad.Except (ExceptT, MonadError, runExceptT)
import Control.Monad.State (MonadState, State, evalState, gets,
modify)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Tuple.Extra (dupe)
import Grammar.Abs
import Grammar.ErrM (Err)
import Grammar.Print (printTree)
-- | Rename all variables and local binds
rename :: Program -> Err Program
rename (Program defs) = Program <$> renameDefs defs
rename (Program defs) = rename' $ do
ds' <- mapM (fmap DData . rnData) ds
ss' <- mapM (fmap DSig . rnSig) ss
bs' <- mapM (fmap DBind . rnTopBind) bs
pure $ Program (ds' ++ ss' ++ bs')
where
(ds, ss, bs) = partitionDefs defs
rename' = flip evalState initCxt
. runExceptT
. runRn
initCxt = Cxt
{ counter = 0
, names = Map.fromList $ [ dupe n | Sig n _ <- ss ]
++ [ dupe n | Bind n _ _ <- bs ]
}
rnData :: Data -> Rn Data
rnData (Data typ injs) = liftA2 Data (rnType typ) (mapM rnInj injs)
where
rnInj (Inj name t) = Inj name <$> rnType t
initCxt :: Cxt
initCxt = Cxt 0 0
rnSig :: Sig -> Rn Sig
rnSig (Sig name typ) = liftA2 Sig (getName name) (rnType typ)
rnType :: Type -> Rn Type
rnType = \case
TVar (MkTVar name) -> TVar . MkTVar <$> getName name
TData name ts -> TData name <$> localNames (mapM rnType ts)
TFun t1 t2 -> onM TFun (localNames . rnType) t1 t2
TAll (MkTVar name) t -> liftA2 (TAll . MkTVar) (newName name) (rnType t)
typ -> pure typ
rnTopBind :: Bind -> Rn Bind
rnTopBind = rnBind' False
rnLocalBind :: Bind -> Rn Bind
rnLocalBind = rnBind' True
rnBind' :: Bool -> Bind -> Rn Bind
rnBind' isLocal (Bind name vars rhs) = do
name' <- if isLocal then newName name else getName name
(vars', rhs') <- localNames $ liftA2 (,) (mapM newName vars) (rnExp rhs)
pure (Bind name' vars' rhs')
rnExp :: Exp -> Rn Exp
rnExp = \case
EVar x -> EVar <$> getName x
EInj x -> pure (EInj x)
ELit lit -> pure (ELit lit)
EApp e1 e2 -> onM EApp (localNames . rnExp) e1 e2
EAdd e1 e2 -> onM EAdd (localNames . rnExp) e1 e2
ELet bind e -> liftA2 ELet (rnLocalBind bind) (rnExp e)
EAbs x e -> liftA2 EAbs (newName x) (rnExp e)
EAnn e t -> liftA2 EAnn (rnExp e) (rnType t)
ECase e bs -> liftA2 ECase (rnExp e) (mapM (localNames . rnBranch) bs)
rnBranch :: Branch -> Rn Branch
rnBranch (Branch p e) = liftA2 Branch (rnPattern p) (rnExp e)
rnPattern :: Pattern -> Rn Pattern
rnPattern = \case
PVar x -> PVar <$> newName x
PLit lit -> pure (PLit lit)
PCatch -> pure PCatch
PEnum name -> pure (PEnum name)
PInj name ps -> PInj name <$> mapM rnPattern ps
data Cxt = Cxt
{ var_counter :: Int
, tvar_counter :: Int
{ counter :: Int
, names :: Map LIdent LIdent
}
-- | Rename monad. State holds the number of renamed names.
newtype Rn a = Rn {runRn :: ExceptT String (State Cxt) a}
deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
-- | Maps old to new name
type Names = Map String String
getName :: LIdent -> Rn LIdent
getName name = maybeToRightM err =<< gets (Map.lookup name . names)
where err = "Can't find new name " ++ printTree name
renameDefs :: [Def] -> Err [Def]
renameDefs defs = evalState (runExceptT (runRn $ mapM renameDef defs)) initCxt
newName :: LIdent -> Rn LIdent
newName name = do
name' <- gets (mk name . counter)
modify $ \cxt -> cxt { counter = succ cxt.counter
, names = Map.insert name name' cxt.names
}
pure name'
where
initNames = Map.fromList [dupe s | DBind (Bind (LIdent s) _ _) <- defs]
mk (LIdent name) i = LIdent ("#" ++ show i ++ name)
renameDef :: Def -> Rn Def
renameDef = \case
DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ
DBind (Bind name vars rhs) -> do
(new_names, vars') <- newNamesL initNames vars
rhs' <- snd <$> renameExp new_names rhs
pure . DBind $ Bind name vars' rhs'
DData (Data typ injs) -> do
tvars <- collectTVars [] typ
tvars' <- mapM nextNameTVar tvars
let tvars_lt = zip tvars tvars'
typ' = substituteTVar tvars_lt typ
injs' = map (renameInj tvars_lt) injs
pure . DData $ Data typ' injs'
where
collectTVars tvars = \case
TAll tvar t -> collectTVars (tvar : tvars) t
TData _ _ -> pure tvars
_ -> throwError ("Bad data type definition: " ++ printTree typ)
renameInj :: [(TVar, TVar)] -> Inj -> Inj
renameInj new_types (Inj name typ) =
Inj name $ substituteTVar new_types typ
substituteTVar :: [(TVar, TVar)] -> Type -> Type
substituteTVar new_names typ = case typ of
TLit _ -> typ
TVar tvar
| Just tvar' <- lookup tvar new_names ->
TVar tvar'
| otherwise ->
typ
TFun t1 t2 -> on TFun substitute' t1 t2
TAll tvar t
| Just tvar' <- lookup tvar new_names ->
TAll tvar' $ substitute' t
| otherwise ->
TAll tvar $ substitute' t
TData name typs -> TData name $ map substitute' typs
_ -> error ("Impossible " ++ show typ)
where
substitute' = substituteTVar new_names
renameExp :: Names -> Exp -> Rn (Names, Exp)
renameExp old_names = \case
EVar (LIdent n) -> pure (old_names, EVar . LIdent . fromMaybe n $ Map.lookup n old_names)
EInj (UIdent n) -> pure (old_names, EInj . UIdent . fromMaybe n $ Map.lookup n old_names)
ELit lit -> pure (old_names, ELit lit)
EApp e1 e2 -> do
(env1, e1') <- renameExp old_names e1
(env2, e2') <- renameExp old_names e2
pure (Map.union env1 env2, EApp e1' e2')
EAdd e1 e2 -> do
(env1, e1') <- renameExp old_names e1
(env2, e2') <- renameExp old_names e2
pure (Map.union env1 env2, EAdd e1' e2')
-- TODO fix shadowing
ELet (Bind name vars rhs) e -> do
(new_names, name') <- newNameL old_names name
(new_names', vars') <- newNamesL new_names vars
(new_names'', rhs') <- renameExp new_names' rhs
(new_names''', e') <- renameExp new_names'' e
pure (new_names''', ELet (Bind name' vars' rhs') e')
EAbs par e -> do
(new_names, par') <- newNameL old_names par
(new_names', e') <- renameExp new_names e
pure (new_names', EAbs par' e')
EAnn e t -> do
(new_names, e') <- renameExp old_names e
t' <- renameTVars t
pure (new_names, EAnn e' t')
ECase e injs -> do
(new_names, e') <- renameExp old_names e
(new_names', injs') <- renameBranches new_names injs
pure (new_names', ECase e' injs')
renameBranches :: Names -> [Branch] -> Rn (Names, [Branch])
renameBranches ns xs = do
(new_names, xs') <- mapAndUnzipM (renameBranch ns) xs
if null new_names then return (mempty, xs') else return (head new_names, xs')
renameBranch :: Names -> Branch -> Rn (Names, Branch)
renameBranch ns b@(Branch patt e) = do
(new_names, patt') <- catchError (evalStateT (renamePattern ns patt) mempty) (\x -> throwError $ x ++ " in pattern '" ++ printTree b ++ "'")
(new_names', e') <- renameExp new_names e
return (new_names', Branch patt' e')
renamePattern :: Names -> Pattern -> StateT (Set LIdent) Rn (Names, Pattern)
renamePattern ns p = case p of
PInj cs ps -> do
(ns_new, ps') <- mapAccumM renamePattern ns ps
return (ns_new, PInj cs ps')
PVar name -> do
vs <- get
when (name `Set.member` vs) (throwError $ "Conflicting definitions of '" ++ printTree name ++ "'")
put (Set.insert name vs)
nn <- lift $ newNameL ns name
return $ second PVar nn
_ -> return (ns, p)
renameTVars :: Type -> Rn Type
renameTVars typ = case typ of
TAll tvar t -> do
tvar' <- nextNameTVar tvar
t' <- renameTVars $ substitute tvar tvar' t
pure $ TAll tvar' t'
TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2)
_ -> pure typ
substitute ::
TVar -> -- α
TVar -> -- α_n
Type -> -- A
Type -- [α_n/α]A
substitute tvar1 tvar2 typ = case typ of
TLit _ -> typ
TVar tvar
| tvar == tvar1 -> TVar tvar2
| otherwise -> typ
TFun t1 t2 -> on TFun substitute' t1 t2
TAll tvar t
| tvar == tvar1 -> TAll tvar2 $ substitute' t
| otherwise -> TAll tvar $ substitute' t
TData name typs -> TData name $ map substitute' typs
_ -> error "Impossible"
where
substitute' = substitute tvar1 tvar2
-- | Create multiple names and add them to the name environment
newNamesL :: Names -> [LIdent] -> Rn (Names, [LIdent])
newNamesL = mapAccumM newNameL
-- | Create a new name and add it to name environment.
newNameL :: Names -> LIdent -> Rn (Names, LIdent)
newNameL env (LIdent old_name) = do
new_name <- makeName old_name
pure (Map.insert old_name new_name env, LIdent new_name)
-- | Create multiple names and add them to the name environment
newNamesU :: Names -> [UIdent] -> Rn (Names, [UIdent])
newNamesU = mapAccumM newNameU
-- | Create a new name and add it to name environment.
newNameU :: Names -> UIdent -> Rn (Names, UIdent)
newNameU env (UIdent old_name) = do
new_name <- makeName old_name
pure (Map.insert old_name new_name env, UIdent new_name)
-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
makeName :: String -> Rn String
makeName prefix = do
i <- gets var_counter
let name = prefix ++ "_" ++ show i
modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
pure name
nextNameTVar :: TVar -> Rn TVar
nextNameTVar (MkTVar (LIdent s)) = do
i <- gets tvar_counter
let tvar = MkTVar . LIdent $ s ++ "_" ++ show i
modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter}
pure tvar
localNames :: MonadState Cxt m => m b -> m b
localNames m = do
old_names <- gets names
m <* modify ( \cxt' -> cxt' { names = old_names })

206
src/Renamer/RenamerOld.hs
View file

@ -1,206 +0,0 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use mapAndUnzipM" #-}
module Renamer.Renamer (rename) where
import Auxiliary (mapAccumM)
import Control.Applicative (Applicative (liftA2))
import Control.Monad (foldM)
import Control.Monad.Except (ExceptT, MonadError, runExceptT,
throwError)
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.State (MonadState, StateT, evalStateT, gets,
modify)
import Data.Coerce (coerce)
import Data.Function (on)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Tuple.Extra (dupe)
import Grammar.Abs
-- | Rename all variables and local binds
rename :: Program -> Either String Program
rename (Program defs) = Program <$> renameDefs defs
renameDefs :: [Def] -> Either String [Def]
renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt
where
initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs]
renameDef :: Def -> Rn Def
renameDef = \case
DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ
DBind bind -> DBind . snd <$> renameBind initNames bind
DData (Data (TData cname types) constrs) -> do
tvars_ <- tvars
tvars' <- mapM nextNameTVar tvars_
let tvars_lt = zip tvars_ tvars'
typ' = map (substituteTVar tvars_lt) types
constrs' = map (renameConstr tvars_lt) constrs
pure . DData $ Data (TData cname typ') constrs'
where
tvars = concat <$> mapM (collectTVars []) types
collectTVars :: [TVar] -> Type -> Rn [TVar]
collectTVars tvars = \case
TAll tvar t -> collectTVars (tvar : tvars) t
TData _ _ -> return tvars
-- Should be monad error
TVar v -> return [v]
_ -> throwError ("Bad data type definition: " ++ show types)
DData (Data types _) -> throwError ("Bad data type definition: " ++ show types)
renameConstr :: [(TVar, TVar)] -> Inj -> Inj
renameConstr new_types (Inj name typ) =
Inj name $ substituteTVar new_types typ
renameBind :: Names -> Bind -> Rn (Names, Bind)
renameBind old_names (Bind name vars rhs) = do
(new_names, vars') <- newNames old_names (coerce vars)
(newer_names, rhs') <- renameExp new_names rhs
pure (newer_names, Bind name (coerce vars') rhs')
substituteTVar :: [(TVar, TVar)] -> Type -> Type
substituteTVar new_names typ = case typ of
TLit _ -> typ
TVar tvar
| Just tvar' <- lookup tvar new_names ->
TVar tvar'
| otherwise ->
typ
TFun t1 t2 -> on TFun substitute' t1 t2
TAll tvar t
| Just tvar' <- lookup tvar new_names ->
TAll tvar' $ substitute' t
| otherwise ->
TAll tvar $ substitute' t
TData name typs -> TData name $ map substitute' typs
_ -> error ("Impossible " ++ show typ)
where
substitute' = substituteTVar new_names
initCxt :: Cxt
initCxt = Cxt 0 0
data Cxt = Cxt
{ var_counter :: Int
, tvar_counter :: Int
}
-- | Rename monad. State holds the number of renamed names.
newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
-- | Maps old to new name
type Names = Map LIdent LIdent
renameExp :: Names -> Exp -> Rn (Names, Exp)
renameExp old_names = \case
EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names)
EInj n -> pure (old_names, EInj n)
ELit lit -> pure (old_names, ELit lit)
EApp e1 e2 -> do
(env1, e1') <- renameExp old_names e1
(env2, e2') <- renameExp old_names e2
pure (Map.union env1 env2, EApp e1' e2')
EAdd e1 e2 -> do
(env1, e1') <- renameExp old_names e1
(env2, e2') <- renameExp old_names e2
pure (Map.union env1 env2, EAdd e1' e2')
-- TODO fix shadowing
ELet bind e -> do
(new_names, bind') <- renameBind old_names bind
(new_names', e') <- renameExp new_names e
pure (new_names', ELet bind' e')
EAbs par e -> do
(new_names, par') <- newName old_names (coerce par)
(new_names', e') <- renameExp new_names e
pure (new_names', EAbs (coerce par') e')
EAnn e t -> do
(new_names, e') <- renameExp old_names e
t' <- renameTVars t
pure (new_names, EAnn e' t')
ECase e injs -> do
(new_names, e') <- renameExp old_names e
(new_names', injs') <- renameBranches new_names injs
pure (new_names', ECase e' injs')
renameBranches :: Names -> [Branch] -> Rn (Names, [Branch])
renameBranches ns xs = do
(new_names, xs') <- unzip <$> mapM (renameBranch ns) xs
if null new_names then return (mempty, xs') else return (head new_names, xs')
renameBranch :: Names -> Branch -> Rn (Names, Branch)
renameBranch ns (Branch init e) = do
(new_names, init') <- renamePattern ns init
(new_names', e') <- renameExp new_names e
return (new_names', Branch init' e')
renamePattern :: Names -> Pattern -> Rn (Names, Pattern)
renamePattern ns i = case i of
PInj cs ps -> do
(ns_new, ps) <- renamePatterns ns ps
return (ns_new, PInj cs ps)
rest -> return (ns, rest)
renamePatterns :: Names -> [Pattern] -> Rn (Names, [Pattern])
renamePatterns ns xs = do
(new_names, xs') <- unzip <$> mapM (renamePattern ns) xs
if null new_names then return (mempty, xs') else return (head new_names, xs')
renameTVars :: Type -> Rn Type
renameTVars typ = case typ of
TAll tvar t -> do
tvar' <- nextNameTVar tvar
t' <- renameTVars $ substitute tvar tvar' t
pure $ TAll tvar' t'
TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2)
_ -> pure typ
substitute ::
TVar -> -- α
TVar -> -- α_n
Type -> -- A
Type -- [α_n/α]A
substitute tvar1 tvar2 typ = case typ of
TLit _ -> typ
TVar tvar'
| tvar' == tvar1 -> TVar tvar2
| otherwise -> typ
TFun t1 t2 -> on TFun substitute' t1 t2
TAll tvar t -> TAll tvar $ substitute' t
TData name typs -> TData name $ map substitute' typs
_ -> error "Impossible"
where
substitute' = substitute tvar1 tvar2
-- | Create a new name and add it to name environment.
newName :: Names -> LIdent -> Rn (Names, LIdent)
newName env old_name = do
new_name <- makeName old_name
pure (Map.insert old_name new_name env, new_name)
-- | Create multiple names and add them to the name environment
newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
newNames = mapAccumM newName
-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
makeName :: LIdent -> Rn LIdent
makeName (LIdent prefix) = do
i <- gets var_counter
let name = LIdent $ prefix ++ "_" ++ show i
modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
pure name
nextNameTVar :: TVar -> Rn TVar
nextNameTVar (MkTVar (LIdent s)) = do
i <- gets tvar_counter
let tvar = MkTVar $ coerce $ s ++ "_" ++ show i
modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter}
pure tvar

70
src/ReportForall.hs Normal file
View file

@ -0,0 +1,70 @@
{-# LANGUAGE LambdaCase #-}
module ReportForall (reportForall) where
import Auxiliary (partitionDefs)
import Control.Monad (unless, void, when)
import Control.Monad.Except (MonadError (throwError))
import Data.Either.Combinators (mapRight)
import Data.Foldable (foldlM)
import Data.Function (on)
import Data.List (delete)
import Grammar.Abs
import Grammar.ErrM (Err)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
reportForall :: TypeChecker -> Program -> Err ()
reportForall tc p = do
when (tc == Hm) $ rpProgram rpaType p
rpProgram rpuType p
rpuType :: Type -> Err ()
rpuType typ = do
tvars <- go [] typ
unless (null tvars) $ throwError "Unused forall"
where
go tvars = \case
TAll tvar t
| tvar `elem` tvars -> throwError "Duplicate forall"
| otherwise -> go (tvar : tvars) t
TVar tvar -> pure (delete tvar tvars)
TFun t1 t2 -> go tvars t1 >>= (`go` t2)
TData _ typs -> foldlM go tvars typs
_ -> pure tvars
rpaType :: Type -> Err ()
rpaType = rpForall . skipForall
where
skipForall = \case
TAll _ t -> skipForall t
t -> t
rpForall = \case
TAll {} -> throwError "Higher rank forall not allowed"
TFun t1 t2 -> on (>>) rpForall t1 t2
TData _ typs -> mapM_ rpForall typs
_ -> pure ()
rpProgram :: (Type -> Err ()) -> Program -> Err ()
rpProgram rf (Program defs) = do
mapM_ rpuBind bs
mapM_ rpuData ds
mapM_ rpuSig ss
where
(ds, ss, bs) = partitionDefs defs
rpuSig (Sig _ typ) = rf typ
rpuData (Data typ injs) = rf typ >> mapM rpuInj injs
rpuInj (Inj _ typ) = rf typ
rpuBind (Bind _ _ rhs) = rpuExp rhs
rpuBranch (Branch _ e) = rpuExp e
rpuExp = \case
EAnn e t -> rpuExp e >> rf t
EApp e1 e2 -> on (>>) rpuExp e1 e2
EAdd e1 e2 -> on (>>) rpuExp e1 e2
ELet bind e -> rpuBind bind >> rpuExp e
EAbs _ e -> rpuExp e
ECase e bs -> rpuExp e >> mapM_ rpuBranch bs
_ -> pure ()
reportAnyForall :: Program -> Err ()
reportAnyForall = undefined

48
src/TypeChecker/RemoveForall.hs Normal file
View file

@ -0,0 +1,48 @@
{-# LANGUAGE LambdaCase #-}
module TypeChecker.RemoveForall (removeForall) where
import Auxiliary (onM)
import Control.Applicative (Applicative (liftA2))
import Data.Function (on)
import Data.List (partition)
import Data.Tuple.Extra (second)
import Grammar.ErrM (Err)
import qualified TypeChecker.ReportTEVar as R
import TypeChecker.TypeCheckerIr
removeForall :: Program' R.Type -> Program
removeForall (Program defs) = Program $ map (DData . rfData) ds
++ map (DBind . rfBind) bs
where
(ds, bs) = ([d | DData d <- defs ], [ b | DBind b <- defs ])
rfData (Data typ injs) = Data (rfType typ) (map rfInj injs)
rfInj (Inj name typ) = Inj name (rfType typ)
rfBind (Bind name vars rhs) = Bind (rfId name) (map rfId vars) (rfExpT rhs)
rfId = second rfType
rfExpT (e, t) = (rfExp e, rfType t)
rfExp = \case
EApp e1 e2 -> on EApp rfExpT e1 e2
EAdd e1 e2 -> on EAdd rfExpT e1 e2
ELet bind e -> ELet (rfBind bind) (rfExpT e)
EAbs name e -> EAbs name (rfExpT e)
ECase e bs -> ECase (rfExpT e) (map rfBranch bs)
ELit lit -> ELit lit
EVar name -> EVar name
EInj name -> EInj name
rfBranch (Branch (p, t) e) = Branch (rfPattern p, rfType t) (rfExpT e)
rfPattern = \case
PVar id -> PVar (rfId id)
PLit (lit, t) -> PLit (lit, rfType t)
PCatch -> PCatch
PEnum name -> PEnum name
PInj name ps -> PInj name (map rfPattern ps)
rfType :: R.Type -> Type
rfType = \case
R.TAll _ t -> rfType t
R.TFun t1 t2 -> on TFun rfType t1 t2
R.TData name ts -> TData name (map rfType ts)
R.TLit lit -> TLit lit
R.TVar tvar -> TVar tvar

71
src/TypeChecker/RemoveTEVar.hs
View file

@ -1,71 +0,0 @@
{-# LANGUAGE LambdaCase #-}
module TypeChecker.RemoveTEVar where
import Control.Applicative (Applicative (liftA2), liftA3)
import Control.Monad.Except (MonadError (throwError))
import Data.Coerce (coerce)
import Data.Tuple.Extra (secondM)
import Grammar.Abs
import Grammar.ErrM (Err)
import TypeChecker.TypeCheckerIr qualified as T
class RemoveTEVar a b where
rmTEVar :: a -> Err b
instance RemoveTEVar (T.Program' Type) (T.Program' T.Type) where
rmTEVar (T.Program defs) = T.Program <$> rmTEVar defs
instance RemoveTEVar (T.Def' Type) (T.Def' T.Type) where
rmTEVar = \case
T.DBind bind -> T.DBind <$> rmTEVar bind
T.DData dat -> T.DData <$> rmTEVar dat
instance RemoveTEVar (T.Bind' Type) (T.Bind' T.Type) where
rmTEVar (T.Bind id vars rhs) = liftA3 T.Bind (rmTEVar id) (rmTEVar vars) (rmTEVar rhs)
instance RemoveTEVar (T.Exp' Type) (T.Exp' T.Type) where
rmTEVar exp = case exp of
T.EVar name -> pure $ T.EVar name
T.EInj name -> pure $ T.EInj name
T.ELit lit -> pure $ T.ELit lit
T.ELet bind e -> liftA2 T.ELet (rmTEVar bind) (rmTEVar e)
T.EApp e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2)
T.EAdd e1 e2 -> liftA2 T.EAdd (rmTEVar e1) (rmTEVar e2)
T.EAbs name e -> T.EAbs name <$> rmTEVar e
T.ECase e branches -> liftA2 T.ECase (rmTEVar e) (rmTEVar branches)
instance RemoveTEVar (T.Branch' Type) (T.Branch' T.Type) where
rmTEVar (T.Branch (patt, t_patt) e) = liftA2 T.Branch (liftA2 (,) (rmTEVar patt) (rmTEVar t_patt)) (rmTEVar e)
instance RemoveTEVar (T.Pattern' Type) (T.Pattern' T.Type) where
rmTEVar = \case
T.PVar (name, t) -> T.PVar . (name,) <$> rmTEVar t
T.PLit (lit, t) -> T.PLit . (lit,) <$> rmTEVar t
T.PCatch -> pure T.PCatch
T.PEnum name -> pure $ T.PEnum name
T.PInj name ps -> T.PInj name <$> rmTEVar ps
instance RemoveTEVar (T.Data' Type) (T.Data' T.Type) where
rmTEVar (T.Data typ injs) = liftA2 T.Data (rmTEVar typ) (rmTEVar injs)
instance RemoveTEVar (T.Inj' Type) (T.Inj' T.Type) where
rmTEVar (T.Inj name typ) = T.Inj name <$> rmTEVar typ
instance RemoveTEVar (T.Id' Type) (T.Id' T.Type) where
rmTEVar = secondM rmTEVar
instance RemoveTEVar (T.ExpT' Type) (T.ExpT' T.Type) where
rmTEVar (exp, typ) = liftA2 (,) (rmTEVar exp) (rmTEVar typ)
instance RemoveTEVar a b => RemoveTEVar [a] [b] where
rmTEVar = mapM rmTEVar
instance RemoveTEVar Type T.Type where
rmTEVar = \case
TLit lit -> pure $ T.TLit (coerce lit)
TVar (MkTVar i) -> pure $ T.TVar (T.MkTVar $ coerce i)
TData name typs -> T.TData (coerce name) <$> rmTEVar typs
TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2)
TAll (MkTVar i) t -> T.TAll (T.MkTVar $ coerce i) <$> rmTEVar t
TEVar _ -> throwError "NewType TEVar!"

81
src/TypeChecker/ReportTEVar.hs Normal file
View file

@ -0,0 +1,81 @@
{-# LANGUAGE LambdaCase #-}
module TypeChecker.ReportTEVar where
import Auxiliary (onM)
import Control.Applicative (Applicative (liftA2), liftA3)
import Control.Monad.Except (MonadError (throwError))
import Data.Coerce (coerce)
import Data.Tuple.Extra (secondM)
import qualified Grammar.Abs as G
import Grammar.ErrM (Err)
import TypeChecker.TypeCheckerIr hiding (Type (..))
data Type
= TLit Ident
| TVar TVar
| TData Ident [Type]
| TFun Type Type
| TAll TVar Type
deriving (Eq, Ord, Show, Read)
class ReportTEVar a b where
reportTEVar :: a -> Err b
instance ReportTEVar (Program' G.Type) (Program' Type) where
reportTEVar (Program defs) = Program <$> reportTEVar defs
instance ReportTEVar (Def' G.Type) (Def' Type) where
reportTEVar = \case
DBind bind -> DBind <$> reportTEVar bind
DData dat -> DData <$> reportTEVar dat
instance ReportTEVar (Bind' G.Type) (Bind' Type) where
reportTEVar (Bind id vars rhs) = liftA3 Bind (reportTEVar id) (reportTEVar vars) (reportTEVar rhs)
instance ReportTEVar (Exp' G.Type) (Exp' Type) where
reportTEVar exp = case exp of
EVar name -> pure $ EVar name
EInj name -> pure $ EInj name
ELit lit -> pure $ ELit lit
ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e)
EApp e1 e2 -> onM EApp reportTEVar e1 e2
EAdd e1 e2 -> onM EAdd reportTEVar e1 e2
EAbs name e -> EAbs name <$> reportTEVar e
ECase e branches -> liftA2 ECase (reportTEVar e) (reportTEVar branches)
instance ReportTEVar (Branch' G.Type) (Branch' Type) where
reportTEVar (Branch (patt, t_patt) e) = liftA2 Branch (liftA2 (,) (reportTEVar patt) (reportTEVar t_patt)) (reportTEVar e)
instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where
reportTEVar = \case
PVar (name, t) -> PVar . (name,) <$> reportTEVar t
PLit (lit, t) -> PLit . (lit,) <$> reportTEVar t
PCatch -> pure PCatch
PEnum name -> pure $ PEnum name
PInj name ps -> PInj name <$> reportTEVar ps
instance ReportTEVar (Data' G.Type) (Data' Type) where
reportTEVar (Data typ injs) = liftA2 Data (reportTEVar typ) (reportTEVar injs)
instance ReportTEVar (Inj' G.Type) (Inj' Type) where
reportTEVar (Inj name typ) = Inj name <$> reportTEVar typ
instance ReportTEVar (Id' G.Type) (Id' Type) where
reportTEVar = secondM reportTEVar
instance ReportTEVar (ExpT' G.Type) (ExpT' Type) where
reportTEVar (exp, typ) = liftA2 (,) (reportTEVar exp) (reportTEVar typ)
instance ReportTEVar a b => ReportTEVar [a] [b] where
reportTEVar = mapM reportTEVar
instance ReportTEVar G.Type Type where
reportTEVar = \case
G.TLit lit -> pure $ TLit (coerce lit)
G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i)
G.TData name typs -> TData (coerce name) <$> reportTEVar typs
G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2)
G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t
G.TEVar _ -> throwError "NewType TEVar!"

22
src/TypeChecker/TypeChecker.hs
View file

@ -1,17 +1,19 @@
module TypeChecker.TypeChecker (typecheck, TypeChecker (..)) where
import Control.Monad ((<=<))
import Grammar.Abs
import Grammar.ErrM (Err)
import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar))
import TypeChecker.TypeCheckerBidir qualified as Bi
import TypeChecker.TypeCheckerHm qualified as Hm
import TypeChecker.TypeCheckerIr qualified as T
import Control.Monad ((<=<))
import qualified Grammar.Abs as G
import Grammar.ErrM (Err)
import TypeChecker.RemoveForall (removeForall)
import qualified TypeChecker.ReportTEVar as R
import TypeChecker.ReportTEVar (reportTEVar)
import qualified TypeChecker.TypeCheckerBidir as Bi
import qualified TypeChecker.TypeCheckerHm as Hm
import TypeChecker.TypeCheckerIr
data TypeChecker = Bi | Hm
data TypeChecker = Bi | Hm deriving Eq
typecheck :: TypeChecker -> Program -> Err T.Program
typecheck tc = rmTEVar <=< f
typecheck :: TypeChecker -> G.Program -> Err Program
typecheck tc = fmap removeForall . (reportTEVar <=< f)
where
f = case tc of
Bi -> Bi.typecheck

16
src/TypeChecker/TypeCheckerBidir.hs
View file

@ -121,6 +121,7 @@ typecheckBind (Bind name vars rhs) = do
, "Did you forget to add type annotation to a polymorphic function?"
]
-- TODO remove some checks
typecheckDataType :: Data -> Err (T.Data' Type)
typecheckDataType (Data typ injs) = do
(name, tvars) <- go [] typ
@ -135,6 +136,7 @@ typecheckDataType (Data typ injs) = do
-> pure (name, tvars')
_ -> throwError $ unwords ["Bad data type definition: ", ppT typ]
-- TODO remove some checks
typecheckInj :: Inj -> UIdent -> [TVar] -> Err (T.Inj' Type)
typecheckInj (Inj inj_name inj_typ) name tvars
| not $ boundTVars tvars inj_typ
@ -878,18 +880,18 @@ traceTs s xs = trace (s ++ " [ " ++ intercalate ", " (map ppT xs) ++ " ]") pure
ppT = \case
TLit (UIdent s) -> s
TVar (MkTVar (LIdent s)) -> "α_" ++ s
TFun t1 t2 -> ppT t1 ++ "→" ++ ppT t2
TVar (MkTVar (LIdent s)) -> "a_" ++ s
TFun t1 t2 -> ppT t1 ++ "->" ++ ppT t2
TAll (MkTVar (LIdent s)) t -> "forall " ++ s ++ ". " ++ ppT t
TEVar (MkTEVar (LIdent s)) -> "ά_" ++ s
TEVar (MkTEVar (LIdent s)) -> "a^_" ++ s
TData (UIdent name) typs -> name ++ " (" ++ unwords (map ppT typs)
++ " )"
ppEnvElem = \case
EnvVar (LIdent s) t -> s ++ ":" ++ ppT t
EnvTVar (MkTVar (LIdent s)) -> "α_" ++ s
EnvTEVar (MkTEVar (LIdent s)) -> "ά_" ++ s
EnvTEVarSolved (MkTEVar (LIdent s)) t -> "ά_" ++ s ++ "=" ++ ppT t
EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "ά_" ++ s
EnvTVar (MkTVar (LIdent s)) -> "a_" ++ s
EnvTEVar (MkTEVar (LIdent s)) -> "a^_" ++ s
EnvTEVarSolved (MkTEVar (LIdent s)) t -> "_" ++ s ++ "=" ++ ppT t
EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "a^_" ++ s
ppEnv = \case
Empty -> "·"

148
src/TypeChecker/TypeCheckerHm.hs
View file

@ -1,31 +1,31 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}
-- | A module for type checking and inference using algorithm W, Hindley-Milner
module TypeChecker.TypeCheckerHm where
import Auxiliary (int, litType, maybeToRightM, unzip4)
import Auxiliary qualified as Aux
import Control.Monad.Except
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Coerce (coerce)
import Data.Function (on)
import Data.List (foldl', nub, sortOn)
import Data.List.Extra (unsnoc)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromJust)
import Data.Set (Set)
import Data.Set qualified as S
import Debug.Trace (trace)
import Grammar.Abs
import Grammar.Print (printTree)
import TypeChecker.TypeCheckerIr qualified as T
import Auxiliary (int, litType, maybeToRightM, unzip4)
import qualified Auxiliary as Aux
import Control.Monad.Except
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Coerce (coerce)
import Data.Function (on)
import Data.List (foldl', nub, sortOn)
import Data.List.Extra (unsnoc)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Set as S
import Debug.Trace (trace)
import Grammar.Abs
import Grammar.Print (printTree)
import qualified TypeChecker.TypeCheckerIr as T
-- TODO: Disallow mutual recursion
@ -34,7 +34,7 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning])
typecheck = onLeft msg . run . checkPrg
where
onLeft :: (Error -> String) -> Either Error a -> Either String a
onLeft f (Left x) = Left $ f x
onLeft f (Left x) = Left $ f x
onLeft _ (Right x) = Right x
checkPrg :: Program -> Infer (T.Program' Type)
@ -118,7 +118,7 @@ preRun (x : xs) = case x of
s <- gets sigs
case M.lookup (coerce n) s of
Nothing -> insertSig (coerce n) Nothing >> preRun xs
Just _ -> preRun xs
Just _ -> preRun xs
DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs
where
-- Check if function body / signature has been declared already
@ -140,11 +140,11 @@ checkDef (x : xs) = case x of
T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs
freeOrdered :: Type -> [T.Ident]
freeOrdered (TVar (MkTVar a)) = return (coerce a)
freeOrdered (TVar (MkTVar a)) = return (coerce a)
freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t
freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b
freeOrdered (TData _ a) = concatMap freeOrdered a
freeOrdered _ = mempty
freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b
freeOrdered (TData _ a) = concatMap freeOrdered a
freeOrdered _ = mempty
checkBind :: Bind -> Infer (T.Bind' Type)
checkBind (Bind name args e) = do
@ -178,22 +178,19 @@ checkBind (Bind name args e) = do
checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m ()
checkData err@(Data typ injs) = do
(name, tvars) <- go typ
(name, tvars) <- go (skipForalls typ)
dataErr (mapM_ (\i -> checkInj i name tvars) injs) err
where
go = \case
TData name typs
| Right tvars' <- mapM toTVar typs ->
pure (name, tvars')
TAll _ _ -> uncatchableErr "Explicit forall not allowed, for now"
_ ->
uncatchableErr $
unwords ["Bad data type definition: ", printTree typ]
checkInj :: (MonadError Error m, MonadState Env m, Monad m) => Inj -> UIdent -> [TVar] -> m ()
checkInj (Inj c inj_typ) name tvars
| Right False <- boundTVars tvars inj_typ =
catchableErr "Unbound type variables"
| TData name' typs <- returnType inj_typ
, Right tvars' <- mapM toTVar typs
, name' == name
@ -217,27 +214,15 @@ checkInj (Inj c inj_typ) name tvars
, "\nActual: "
, printTree $ returnType inj_typ
]
where
boundTVars :: [TVar] -> Type -> Either Error Bool
boundTVars tvars' = \case
TAll{} -> uncatchableErr "Explicit forall not allowed, for now"
TFun t1 t2 -> do
t1' <- boundTVars tvars t1
t2' <- boundTVars tvars t2
return $ t1' && t2'
TVar tvar -> return $ tvar `elem` tvars'
TData _ typs -> and <$> mapM (boundTVars tvars) typs
TLit _ -> return True
TEVar _ -> error "TEVar in data type declaration"
toTVar :: Type -> Either Error TVar
toTVar = \case
TVar tvar -> pure tvar
_ -> uncatchableErr "Not a type variable"
_ -> uncatchableErr "Not a type variable"
returnType :: Type -> Type
returnType (TFun _ t2) = returnType t2
returnType a = a
returnType a = a
inferExp :: Exp -> Infer (T.ExpT' Type)
inferExp e = do
@ -250,7 +235,7 @@ class CollectTVars a where
instance CollectTVars Exp where
collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e
collectTVars _ = S.empty
collectTVars _ = S.empty
instance CollectTVars Type where
collectTVars (TVar (MkTVar i)) = S.singleton (coerce i)
@ -569,12 +554,12 @@ generalize :: Map T.Ident Type -> Type -> Type
generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t)
where
go :: [T.Ident] -> Type -> Type
go [] t = t
go [] t = t
go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t)
removeForalls :: Type -> Type
removeForalls (TAll _ t) = removeForalls t
removeForalls (TAll _ t) = removeForalls t
removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2)
removeForalls t = t
removeForalls t = t
{- | Instantiate a polymorphic type. The free type variables are substituted
with fresh ones.
@ -611,42 +596,39 @@ currently this is not the case, the TAll pattern match is incorrectly implemente
-- Is the left a subtype of the right
(<<=) :: Type -> Type -> Bool
(<<=) (TVar _) _ = True
(<<=) (TAll _ t1) (TAll _ t2) = t1 <<= t2
(<<=) t1@TAll{} t2 = skipForalls t1 <<= t2
(<<=) t1 t2@TAll{} = t1 <<= skipForalls t2
(<<=) (TFun a b) (TFun c d) = a <<= c && b <<= d
(<<=) (TData n1 ts1) (TData n2 ts2) =
n1 == n2
&& length ts1 == length ts2
&& and (zipWith (<<=) ts1 ts2)
(<<=) t0 t@(TAll _ _) = go t0 t
where
go t0 t@(TAll _ t1) = S.toList (free t0) == foralls t && go' t0 t1
go _ _ = undefined
go' (TEVar (MkTEVar a)) (TVar (MkTVar b)) = a == b
go' (TEVar (MkTEVar a)) (TEVar (MkTEVar b)) = a == b
go' (TFun a b) (TFun c d) = a `go'` c && b `go'` d
go' _ _ = False
(<<=) a b = a == b
skipForalls :: Type -> Type
skipForalls = \case
TAll _ t -> t
t -> t
foralls :: Type -> [T.Ident]
foralls (TAll (MkTVar a) t) = coerce a : foralls t
foralls _ = []
foralls _ = []
mkForall :: Type -> Type
mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of
[] -> t
(x : xs) ->
let f acc [] = acc
let f acc [] = acc
f acc (x : xs) = f (x acc) xs
(y : ys) = reverse $ x : xs
in f (y t) ys
skolemize :: Type -> Type
skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a
skolemize (TAll x t) = TAll x (skolemize t)
skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2
skolemize (TData n ts) = TData n (map skolemize ts)
skolemize t = t
skolemize (TAll x t) = TAll x (skolemize t)
skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2
skolemize (TData n ts) = TData n (map skolemize ts)
skolemize t = t
-- | A class for substitutions
class SubstType t where
@ -680,10 +662,10 @@ instance SubstType Type where
TLit _ -> t
TVar (MkTVar a) -> case M.lookup (coerce a) sub of
Nothing -> TVar (MkTVar $ coerce a)
Just t -> t
Just t -> t
TAll (MkTVar i) t -> case M.lookup (coerce i) sub of
Nothing -> TAll (MkTVar i) (apply sub t)
Just _ -> apply sub t
Just _ -> apply sub t
TFun a b -> TFun (apply sub a) (apply sub b)
TData name a -> TData name (apply sub a)
TEVar (MkTEVar _) -> t
@ -728,10 +710,10 @@ instance SubstType (T.Branch' Type) where
instance SubstType (T.Pattern' Type) where
apply s = \case
T.PVar (iden, t) -> T.PVar (iden, apply s t)
T.PLit (lit, t) -> T.PLit (lit, apply s t)
T.PInj i ps -> T.PInj i $ apply s ps
T.PCatch -> T.PCatch
T.PEnum i -> T.PEnum i
T.PLit (lit, t) -> T.PLit (lit, apply s t)
T.PInj i ps -> T.PInj i $ apply s ps
T.PCatch -> T.PCatch
T.PEnum i -> T.PEnum i
instance SubstType (T.Pattern' Type, Type) where
apply s (p, t) = (apply s p, apply s t)
@ -773,10 +755,10 @@ withBindings xs =
withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a
withPattern p ma = case p of
T.PVar (x, t) -> withBinding x t ma
T.PInj _ ps -> foldl' (flip withPattern) ma ps
T.PLit _ -> ma
T.PCatch -> ma
T.PEnum _ -> ma
T.PInj _ ps -> foldl' (flip withPattern) ma ps
T.PLit _ -> ma
T.PCatch -> ma
T.PEnum _ -> ma
-- | Insert a function signature into the environment
insertSig :: T.Ident -> Maybe Type -> Infer ()
@ -801,11 +783,11 @@ existInj n = gets (M.lookup n . injections)
flattenType :: Type -> [Type]
flattenType (TFun a b) = flattenType a <> flattenType b
flattenType a = [a]
flattenType a = [a]
typeLength :: Type -> Int
typeLength (TFun _ b) = 1 + typeLength b
typeLength _ = 1
typeLength _ = 1
{- | Catch an error if possible and add the given
expression as addition to the error message
@ -888,11 +870,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type}
deriving (Show)
data Env = Env
{ count :: Int
, nextChar :: Char
, sigs :: Map T.Ident (Maybe Type)
{ count :: Int
, nextChar :: Char
, sigs :: Map T.Ident (Maybe Type)
, takenTypeVars :: Set T.Ident
, injections :: Map T.Ident Type
, injections :: Map T.Ident Type
, declaredBinds :: Set T.Ident
}
deriving (Show)

32
src/TypeChecker/TypeCheckerIr.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
module TypeChecker.TypeCheckerIr (
@ -6,11 +6,11 @@ module TypeChecker.TypeCheckerIr (
module TypeChecker.TypeCheckerIr,
) where
import Data.String (IsString)
import Grammar.Abs (Lit (..))
import Grammar.Print
import Prelude
import Prelude qualified as C (Eq, Ord, Read, Show)
import Data.String (IsString)
import Grammar.Abs (Lit (..))
import Grammar.Print
import Prelude
import qualified Prelude as C (Eq, Ord, Read, Show)
newtype Program' t = Program [Def' t]
deriving (C.Eq, C.Ord, C.Show, C.Read, Functor)
@ -25,8 +25,7 @@ data Type
| TVar TVar
| TData Ident [Type]
| TFun Type Type
| TAll TVar Type
deriving (C.Eq, C.Ord, C.Show, C.Read)
deriving (Eq, Ord, Show, Read)
data Data' t = Data t [Inj' t]
deriving (C.Eq, C.Ord, C.Show, C.Read, Functor)
@ -105,8 +104,8 @@ instance Print t => Print (ExpT' t) where
]
instance Print t => Print [Bind' t] where
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
prtIdPs :: Print t => Int -> [Id' t] -> Doc
@ -171,13 +170,13 @@ instance Print t => Print (Branch' t) where
prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp])
instance Print t => Print [Branch' t] where
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
instance Print t => Print (Def' t) where
prt i = \case
DBind bind -> prPrec i 0 (concatD [prt 0 bind])
DBind bind -> prPrec i 0 (concatD [prt 0 bind])
DData data_ -> prPrec i 0 (concatD [prt 0 data_])
instance Print t => Print (Data' t) where
@ -202,12 +201,12 @@ instance Print t => Print (Pattern' t) where
PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns])
instance Print t => Print [Def' t] where
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ [] = concatD []
prt _ [x] = concatD [prt 0 x]
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
instance Print [Type] where
prt _ [] = concatD []
prt _ [] = concatD []
prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs]
instance Print Type where
@ -216,7 +215,6 @@ instance Print Type where
TVar tvar -> prPrec i 1 (concatD [prt 0 tvar])
TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")])
TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2])
TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_])
instance Print TVar where
prt i (MkTVar ident) = prt i ident

6
tests/Tests.hs → tests/Main.hs
View file

@ -1,10 +1,16 @@
module Main where
import Test.Hspec
import TestAnnForall (testAnnForall)
import TestRenamer (testRenamer)
import TestReportForall (testReportForall)
import TestTypeCheckerBidir (testTypeCheckerBidir)
import TestTypeCheckerHm (testTypeCheckerHm)
main = hspec $ do
testReportForall
testAnnForall
testRenamer
testTypeCheckerBidir
testTypeCheckerHm

113
tests/TestAnnForall.hs Normal file
View file

@ -0,0 +1,113 @@
{-# LANGUAGE PatternSynonyms #-}
{-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE QualifiedDo #-}
module TestAnnForall (testAnnForall, test) where
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import qualified DoStrings as D
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import Test.Hspec (describe, hspec, shouldBe,
shouldNotSatisfy, shouldSatisfy,
shouldThrow, specify)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T
test = hspec testAnnForall
testAnnForall = describe "Test AnnForall" $ do
ann_data1
ann_data2
ann_bad_data1
ann_bad_data2
ann_bad_data3
ann_sig1
ann_sig2
ann_bind
ann_data1 = specify "Annotate data type" $
D.do "data Either (a b) where"
" Left : a -> Either (a b)"
" Right : b -> Either (a b)"
`shouldBePrg`
D.do "data forall a. forall b. Either (a b) where"
" Left : a -> Either (a b)"
" Right : b -> Either (a b)"
ann_data2 = specify "Annotate constructor with additional type variable" $
D.do "data forall a. forall b. Either (a b) where"
" Left : c -> a -> Either (a b)"
" Right : b -> Either (a b)"
`shouldBePrg`
D.do "data forall a. forall b. Either (a b) where"
" Left : forall c. c -> a -> Either (a b)"
" Right : b -> Either (a b)"
ann_bad_data1 = specify "Bad data type variables" $
D.do "data Either (Int b) where"
" Left : a -> Either (a b)"
" Right : b -> Either (a b)"
`shouldBeErr`
"Misformed data declaration: Non type variable argument"
ann_bad_data2 = specify "Bad data identifer" $
D.do "data Int -> Either (a b) where"
" Left : a -> Either (a b)"
" Right : b -> Either (a b)"
`shouldBeErr`
"Misformed data declaration"
ann_bad_data3 = specify "Constructor forall duplicate" $
D.do "data Int -> Either (a b) where"
" Left : forall a. a -> Either (a b)"
" Right : b -> Either (a b)"
`shouldBeErr`
"Misformed data declaration"
ann_sig1 = specify "Annotate signature" $
"f : a -> b -> (forall a. a -> a) -> a"
`shouldBePrg`
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
ann_sig2 = specify "Annotate signature 2" $
D.do "const : forall a. forall b. a -> b -> a"
"const x y = x"
"main = const 'a' 65"
`shouldBePrg`
D.do "const : forall a. forall b. a -> b -> a"
"const x y = x"
"main = const 'a' 65"
ann_bind = specify "Annotate bind" $
"f = (\\x.\\y. x : a -> b -> a) 4"
`shouldBePrg`
"f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4"
shouldBeErr s err = run s `shouldBe` Bad err
shouldBePrg s1 s2
| Ok p2 <- run' s2 = run s1 `shouldBe` Ok p2
| otherwise = error ("Faulty expectation \n" ++ show (run' s2))
run = annotateForall <=< run'
run' s = do
p <- run'' s
reportForall Bi p
pure p
run'' = pProgram . resolveLayout True . myLexer
runPrint = (putStrLn . either show printTree . run) $
D.do "data forall a. forall b. Either (a b) where"
" Left : c -> a -> Either (a b)"
" Right : b -> Either (a b)"

96
tests/TestRenamer.hs Normal file
View file

@ -0,0 +1,96 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE QualifiedDo #-}
module TestRenamer (testRenamer, test, runPrint) where
import AnnForall (annotateForall)
import Control.Exception (ErrorCall (ErrorCall),
Exception (displayException),
SomeException (SomeException),
evaluate, try)
import Control.Exception.Extra (try_)
import Control.Monad (unless, (<=<))
import Control.Monad.Except (throwError)
import Data.Either.Extra (fromEither)
import qualified DoStrings as D
import GHC.Generics (Generic, Generic1)
import Grammar.Abs (Program (Program))
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import System.IO.Error (catchIOError, tryIOError)
import Test.Hspec (anyErrorCall, anyException,
describe, hspec, shouldBe,
shouldNotSatisfy, shouldReturn,
shouldSatisfy, shouldThrow,
specify)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T
-- FIXME tests sucks
test = hspec testRenamer
testRenamer = describe "Test Renamer" $ do
rn_data1
rn_data2
rn_sig
rn_bind1
rn_bind2
rn_data1 = specify "Rename data type" . shouldSatisfyOk $
D.do "data forall a. forall b. Either (a b) where"
" Left : a -> Either (a b)"
" Right : b -> Either (a b)"
rn_data2 = specify "Rename data type forall in constructor " . shouldSatisfyOk $
D.do "data forall a. forall b. Either (a b) where"
" Left : forall c. c -> a -> Either (a b)"
" Right : b -> Either (a b)"
rn_sig = specify "Rename signature" $ shouldSatisfyOk
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
rn_bind1 = specify "Rename simple bind" $ shouldSatisfyOk
"f x = (\\y. let y2 = y + 1 in y2) (x + 1)"
rn_bind2 = specify "Rename bind with case" . shouldSatisfyOk $
D.do "data forall a. List (a) where"
" Nil : List (a) "
" Cons : a -> List (a) -> List (a)"
"length : forall a. List (a) -> Int"
"length list = case list of"
" Nil => 0"
" Cons x Nil => 1"
" Cons x (Cons y ys) => 2 + length ys"
runPrint = putStrLn . either show printTree . run $
D.do "data forall a. List (a) where"
" Nil : List (a) "
" Cons : a -> List (a) -> List (a)"
"length : forall a. List (a) -> Int"
"length list = case list of"
" Nil => 0"
" Cons x Nil => 1"
" Cons x (Cons y ys) => 2 + length ys"
shouldSatisfyOk s = run s `shouldSatisfy` ok
ok = \case
Ok !_ -> True
Bad !_ -> False
shouldBeErr s err = run s `shouldBe` Bad err
run = rename <=< run'
run' = pProgram . resolveLayout True . myLexer

47
tests/TestReportForall.hs Normal file
View file

@ -0,0 +1,47 @@
{-# LANGUAGE PatternSynonyms #-}
{-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module TestReportForall (testReportForall, test) where
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import qualified DoStrings as D
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import Test.Hspec (describe, hspec, shouldBe,
shouldNotSatisfy, shouldSatisfy,
shouldThrow, specify)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
testReportForall = describe "Test ReportForall" $ do
rp_unused1
rp_unused2
rp_forall
test = hspec testReportForall
rp_unused1 = specify "Unused forall 1" $
"g : forall a. forall a. a -> (forall a. a -> a) -> a"
`shouldBeErrBi`
"Duplicate forall"
rp_unused2 = specify "Unused forall 2" $
"g : forall a. (forall a. a -> a) -> Int"
`shouldBeErrBi`
"Unused forall"
rp_forall = specify "Rank2 forall with Hm" $
"f : a -> b -> (forall a. a -> a) -> a"
`shouldBeErrHm`
"Higher rank forall not allowed"
shouldBeErrBi = shouldBeErr Bi
shouldBeErrHm = shouldBeErr Hm
shouldBeErr tc s err = run tc s `shouldBe` Bad err
run tc = reportForall tc <=< pProgram . resolveLayout True . myLexer

62
tests/TestTypeCheckerBidir.hs
View file

@ -8,19 +8,25 @@ module TestTypeCheckerBidir (test, testTypeCheckerBidir) where
import Test.Hspec
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import Grammar.Abs (Program)
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar))
import ReportForall (reportForall)
import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T
test = hspec testTypeCheckerBidir
testTypeCheckerBidir = describe "Bidirectional type checker test" $ do
testTypeCheckerBidir = describe "Test Bidirectional type checker" $ do
tc_id
tc_double
tc_add_lam
@ -39,7 +45,7 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do
tc_id =
specify "Basic identity function polymorphism" $
run
[ "id : forall a. a -> a"
[ "id : a -> a"
, "id x = x"
, "main = id 4"
]
@ -60,7 +66,7 @@ tc_add_lam =
tc_const =
specify "Basic polymorphism with multiple type variables" $
run
[ "const : forall a. forall b. a -> b -> a"
[ "const : a -> b -> a"
, "const x y = x"
, "main = const 'a' 65"
]
@ -69,9 +75,9 @@ tc_const =
tc_simple_rank2 =
specify "Simple rank two polymorphism" $
run
[ "id : forall a. a -> a"
[ "id : a -> a"
, "id x = x"
, "f : forall a. a -> (forall b. b -> b) -> a"
, "f : a -> (forall b. b -> b) -> a"
, "f x g = g x"
, "main = f 4 id"
]
@ -80,11 +86,11 @@ tc_simple_rank2 =
tc_rank2 =
specify "Rank two polymorphism is ok" $
run
[ "const : forall a. forall b. a -> b -> a"
[ "const : a -> b -> a"
, "const x y = x"
, "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int"
, "rank2 : a -> (forall c. c -> Int) -> b -> Int"
, "rank2 x f y = f x + f y"
, "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h'"
, "main = rank2 3 (\\x. const 5 x : a -> Int) 'h'"
]
`shouldSatisfy` ok
@ -93,9 +99,9 @@ tc_identity = describe "(∀b. b → b) should only accept the identity function
specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok
where
fs =
[ "f : forall a. a -> (forall b. b -> b) -> a"
[ "f : a -> (forall b. b -> b) -> a"
, "f x g = g x"
, "id : forall a. a -> a"
, "id : a -> a"
, "id x = x"
, "id_int : Int -> Int"
, "id_int x = x"
@ -114,7 +120,7 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do
specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok
where
fs =
[ "data forall a. forall b. Pair (a b) where"
[ "data Pair (a b) where"
, " Pair : a -> b -> Pair (a b)"
, "main : Pair (Int Char)"
]
@ -126,7 +132,7 @@ tc_tree = describe "Tree. Recursive data type" $ do
specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok
where
fs =
[ "data forall a. Tree (a) where"
[ "data Tree (a) where"
, " Node : a -> Tree (a) -> Tree (a) -> Tree (a)"
, " Leaf : a -> Tree (a)"
]
@ -195,30 +201,30 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
run (fs ++ correct4) `shouldSatisfy` ok
where
fs =
[ "data forall a. List (a) where"
[ "data List (a) where"
, " Nil : List (a)"
, " Cons : a -> List (a) -> List (a)"
]
wrong1 =
[ "length : forall c. List (c) -> Int"
[ "length : List (c) -> Int"
, "length = \\list. case list of"
, " Nil => 0"
, " Cons 6 xs => 1 + length xs"
]
wrong2 =
[ "length : forall c. List (c) -> Int"
[ "length : List (c) -> Int"
, "length = \\list. case list of"
, " Cons => 0"
, " Cons x xs => 1 + length xs"
]
wrong3 =
[ "length : forall c. List (c) -> Int"
[ "length : List (c) -> Int"
, "length = \\list. case list of"
, " 0 => 0"
, " Cons x xs => 1 + length xs"
]
wrong4 =
[ "elems : forall c. List (List(c)) -> Int"
[ "elems : List (List(c)) -> Int"
, "elems = \\list. case list of"
, " Nil => 0"
, " Cons Nil Nil => 0"
@ -226,14 +232,14 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
, " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)"
]
correct1 =
[ "length : forall c. List (c) -> Int"
[ "length : List (c) -> Int"
, "length = \\list. case list of"
, " Nil => 0"
, " Cons x xs => 1 + length xs"
, " Cons x (Cons y Nil) => 2"
]
correct2 =
[ "length : forall c. List (c) -> Int"
[ "length : List (c) -> Int"
, "length = \\list. case list of"
, " Nil => 0"
, " non_empty => 1"
@ -246,7 +252,7 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
, " Cons x (Cons 2 xs) => 2 + length xs"
]
correct4 =
[ "elems : forall c. List (List(c)) -> Int"
[ "elems : List (List(c)) -> Int"
, "elems = \\list. case list of"
, " Nil => 0"
, " Cons Nil Nil => 0"
@ -292,9 +298,19 @@ tc_rec2 = specify "Infer recursive definition with pattern matching" $ run
, " _ => test (x+1)"
] `shouldSatisfy` ok
run :: [String] -> Err T.Program
run = rmTEVar <=< typecheck <=< pProgram . resolveLayout True . myLexer . unlines
run = fmap removeForall
. reportTEVar
<=< typecheck
<=< run'
run' s = do
p <- (pProgram . resolveLayout True . myLexer . unlines) s
reportForall Bi p
(rename <=< annotateForall) p
runPrint = (putStrLn . either show printTree . run')
["double x = x + x"]
ok = \case
Ok _ -> True

74
tests/TestTypeCheckerHm.hs
View file

@ -1,23 +1,25 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE QualifiedDo #-}
module TestTypeCheckerHm where
import Control.Monad ((<=<))
import qualified DoStrings as D
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Prelude (Bool (..), Either (..), fmap,
foldl1, fst, not, ($), (.), (>>))
import Control.Monad (sequence_, (<=<))
import Test.Hspec
-- import Test.QuickCheck
import AnnForall (annotateForall)
import qualified DoStrings as D
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import TypeChecker.TypeChecker (TypeChecker (Hm))
import TypeChecker.TypeCheckerHm (typecheck)
import TypeChecker.TypeCheckerIr (Program)
testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do
foldl1 (>>) goods
foldl1 (>>) bads
foldl1 (>>) bes
sequence_ goods
sequence_ bads
sequence_ bes
goods =
[ testSatisfy
@ -118,26 +120,29 @@ bads =
" };"
)
bad
, testSatisfy
"id with incorrect signature"
( D.do
"id : a -> b;"
"id x = x;"
)
bad
, testSatisfy
"incorrect signature on const"
( D.do
"const : a -> b -> b;"
"const x y = x"
)
bad
, testSatisfy
"incorrect type signature on id lambda"
( D.do
"id = ((\\x. x) : a -> b);"
)
bad
-- FIXME FAILING TEST
-- , testSatisfy
-- "id with incorrect signature"
-- ( D.do
-- "id : a -> b;"
-- "id x = x;"
-- )
-- bad
-- FIXME FAILING TEST
-- , testSatisfy
-- "incorrect signature on const"
-- ( D.do
-- "const : a -> b -> b;"
-- "const x y = x"
-- )
-- bad
-- FIXME FAILING TEST
-- , testSatisfy
-- "incorrect type signature on id lambda"
-- ( D.do
-- "id = ((\\x. x) : a -> b);"
-- )
-- bad
]
bes =
@ -211,6 +216,11 @@ testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe
run = fmap (printTree . fst) . typecheck <=< pProgram . myLexer
run' s = do
p <- (pProgram . resolveLayout True . myLexer) s
reportForall Hm p
(rename <=< annotateForall) p
ok (Right _) = True
ok (Left _) = False