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

Using type annotations in case expressions, monomorphizer now handles case expressions without crashing

Browse source
This commit is contained in:
Rakarake 2023-04-27 13:55:54 +02:00
parent 8782556603
commit 60e12b622e
2 changed files with 21 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

4
sample-programs/mono-1.crf
View file

@ -1,6 +1,6 @@
const x y = x const2 x y = x
f x = (const x 'c') f x = (const2 x 'c')
main = f 5 main = f 5

39
src/Monomorphizer/Monomorphizer.hs
View file

@ -91,7 +91,10 @@ isBindMarked ident = gets (Map.member ident)
-- | Finds main bind. -- | Finds main bind.
getMain :: EnvM T.Bind getMain :: EnvM T.Bind
getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of
Just mainBind -> mainBind
Nothing -> error "main not found in monomorphizer!"
)
-- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime -- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime
-- error when encountering different structures between the two arguments. -- error when encountering different structures between the two arguments.
@ -219,29 +222,23 @@ morphBranch (T.Branch (p, pt) (e, et)) = do
pt' <- getMonoFromPoly pt pt' <- getMonoFromPoly pt
et' <- getMonoFromPoly et et' <- getMonoFromPoly et
env <- ask env <- ask
(p', newLocals) <- morphPattern pt' (locals env) (p, pt) (p', newLocals) <- morphPattern p pt'
local (const env { locals = newLocals }) $ do local (const env { locals = Set.union (locals env) newLocals }) $ do
e' <- morphExp et' e e' <- morphExp et' e
return $ M.Branch (p', pt') (e', et') return $ M.Branch (p', pt') (e', et')
-- | Morphs pattern (pattern => expression), gives the newly bound local variables. morphPattern :: T.Pattern -> M.Type -> EnvM (M.Pattern, Set.Set Ident)
morphPattern :: M.Type -> Set.Set Ident -> (T.Pattern, T.Type) -> EnvM (M.Pattern, Set.Set Ident) morphPattern p expectedType = case p of
morphPattern expectedType ls (p, t) = case p of T.PVar ident -> return (M.PVar (ident, expectedType), Set.singleton ident)
T.PVar ident -> do t' <- getMonoFromPoly t T.PLit lit -> return (M.PLit (convertLit lit, expectedType), Set.empty)
return (M.PVar (ident, t'), Set.insert ident ls) T.PCatch -> return (M.PCatch, Set.empty)
T.PLit lit -> do t' <- getMonoFromPoly t T.PEnum ident -> do morphCons expectedType ident
return (M.PLit (convertLit lit, t'), ls) return (M.PEnum ident, Set.empty)
T.PCatch -> return (M.PCatch, ls) T.PInj ident pts -> do morphCons expectedType ident
-- Constructor ident ts' <- mapM (getMonoFromPoly . snd) pts
T.PEnum ident -> do morphCons expectedType ident let pts' = zip (map fst pts) ts'
return (M.PEnum ident, ls) psSets <- mapM (uncurry morphPattern) pts'
T.PInj ident ps -> do morphCons expectedType ident return (M.PInj ident (map fst psSets), Set.unions $ map snd psSets)
let (M.TData tIdent ts) = expectedType
-- TODO: this is wrong!
pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts)
if length ts == length ps then
return (M.PCatch, Set.singleton $ Ident "$1y")
else return (M.PInj ident (map fst pairs), Set.unions (map snd pairs))
-- | Creates a new identifier for a function with an assigned type. -- | Creates a new identifier for a function with an assigned type.
newFuncName :: M.Type -> T.Bind -> Ident newFuncName :: M.Type -> T.Bind -> Ident