From d097cd28e8d384990d3a172d55de2e2e6b94b85d Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 17:02:54 +0200 Subject: [PATCH 1/3] New morb tree for internal use in monomorphizer, data types implemented --- language.cabal | 2 + sample-programs/mono-2.crf | 13 ++ src/Monomorphizer/DataTypeRemover.hs | 54 ++++++++ src/Monomorphizer/Monomorphizer.hs | 107 ++++++++++++---- src/Monomorphizer/MorbIr.hs | 183 +++++++++++++++++++++++++++ 5 files changed, 334 insertions(+), 25 deletions(-) create mode 100644 sample-programs/mono-2.crf create mode 100644 src/Monomorphizer/DataTypeRemover.hs create mode 100644 src/Monomorphizer/MorbIr.hs diff --git a/language.cabal b/language.cabal index ddf0fa0..1c54e3f 100644 --- a/language.cabal +++ b/language.cabal @@ -40,6 +40,8 @@ executable language LambdaLifter Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr + Monomorphizer.MorbIr + Monomorphizer.DataTypeRemover Codegen.Codegen Codegen.LlvmIr Codegen.Auxillary diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf new file mode 100644 index 0000000..ade504b --- /dev/null +++ b/sample-programs/mono-2.crf @@ -0,0 +1,13 @@ +data Either(a b) where { + Left: a -> Either (a b) + Right: b -> Either (a b) +}; + +unwrapLeft x = case x of { + Left y => y; +}; + +wow = Left 5; + +main = unwrapLeft wow; + diff --git a/src/Monomorphizer/DataTypeRemover.hs b/src/Monomorphizer/DataTypeRemover.hs new file mode 100644 index 0000000..cf353fb --- /dev/null +++ b/src/Monomorphizer/DataTypeRemover.hs @@ -0,0 +1,54 @@ +module Monomorphizer.DataTypeRemover (removeDataTypes) where +import qualified Monomorphizer.MorbIr as M1 +import qualified Monomorphizer.MonomorphizerIr as M2 +import TypeChecker.TypeCheckerIr (Ident (Ident)) + +removeDataTypes :: M1.Program -> M2.Program +removeDataTypes (M1.Program defs) = M2.Program (map pDef defs) + +pDef :: M1.Def -> M2.Def +pDef (M1.DBind b) = M2.DBind (pBind b) +pDef (M1.DData d) = M2.DData (pData d) + +pData :: M1.Data -> M2.Data +pData (M1.Data t cs) = M2.Data (pType t) (map pCons cs) + +pCons :: M1.Inj -> M2.Inj +pCons (M1.Inj ident t) = M2.Inj ident (pType t) + +pType :: M1.Type -> M2.Type +pType (M1.TLit ident) = M2.TLit ident +pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) +pType (M1.TData (Ident str) args) = M2.TLit (Ident (str ++ show args)) -- This is the step + +pBind :: M1.Bind -> M2.Bind +pBind (M1.Bind id argIds expt) = M2.Bind (pId id) (map pId argIds) (pExpT expt) + +pId :: (Ident, M1.Type) -> (Ident, M2.Type) +pId (ident, t) = (ident, pType t) + +pExpT :: M1.ExpT -> M2.ExpT +pExpT (exp, t) = (pExp exp, pType t) + +pExp :: M1.Exp -> M2.Exp +pExp (M1.EVar ident) = M2.EVar ident +pExp (M1.ELit lit) = M2.ELit (pLit lit) +pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) +pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) +pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) +pExp (M1.ECase expT branches) = M2.ECase (pExpT expT) (map pBranch branches) + +pBranch :: M1.Branch -> M2.Branch +pBranch (M1.Branch (patt, t) expt) = M2.Branch (pPattern patt, pType t) (pExpT expt) + +pPattern :: M1.Pattern -> M2.Pattern +pPattern (M1.PVar id) = M2.PVar (pId id) +pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t) +pPattern (M1.PInj ident patts) = M2.PInj ident (map pPattern patts) +pPattern M1.PCatch = M2.PCatch +pPattern (M1.PEnum ident) = M2.PEnum ident + +pLit :: M1.Lit -> M2.Lit +pLit (M1.LInt v) = M2.LInt v +pLit (M1.LChar c) = M2.LChar c + diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 0a98b00..6d298cd 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -26,15 +26,18 @@ module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr (Ident (Ident)) -import qualified Monomorphizer.MonomorphizerIr as M +import qualified Monomorphizer.MorbIr as M +import qualified Monomorphizer.MonomorphizerIr as O +import Monomorphizer.DataTypeRemover (removeDataTypes) import Debug.Trace -import Control.Monad.State (MonadState, gets, modify, StateT (runStateT)) +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) -- | State Monad wrapper for "Env". newtype EnvM a = EnvM (StateT Output (Reader Env) a) @@ -48,11 +51,13 @@ data Outputted = Incomplete | Complete M.Bind | Data M.Data -- Static environment data Env = Env { -- | All binds in the program. - input :: Map.Map Ident T.Bind, + input :: Map.Map Ident T.Bind, + -- | All constructors and their respective data def. + dataDefs :: Map.Map Ident T.Data, -- | Maps polymorphic identifiers with concrete types. - polys :: Map.Map Ident M.Type, - -- | Local variables - locals :: Set.Set Ident + polys :: Map.Map Ident M.Type, + -- | Local variables. + locals :: Set.Set Ident } localExists :: Ident -> EnvM Bool @@ -85,8 +90,11 @@ 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 pt2 mt2 +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 + then error "Nuh uh" + else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) mapTypes _ _ = error "structure of types not the same!" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. @@ -100,11 +108,10 @@ getMonoFromPoly t = do env <- ask (T.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2) (T.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of Just concrete -> concrete - Nothing -> error $ - "type not found! type: " ++ show ident ++ ", error in previous compilation steps" - -- This is pretty ugly, could use a new type - (T.TData (Ident str) args) -> let args' = map (getMono polys) args in - M.TLit $ Ident (str ++ "$" ++ show args') + 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 @@ -144,6 +151,43 @@ morphApp expectedType (e1, t1) (e2, t2)= do e1' <- morphExp (M.TFun t2' expectedType) e1 return $ M.EApp (e1', t1') (e2', t2') +addOutputData :: M.Data -> EnvM () +addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) + +-- Gets data bind from the name of a constructor +getInputData :: Ident -> EnvM (Maybe T.Data) +getInputData ident = do env <- ask + return $ Map.lookup ident (dataDefs env) + +-- | Expects polymorphic types in data definition to be mapped +-- in environment. +morphData :: T.Data -> EnvM () +morphData (T.Data t cs) = do + t' <- getMonoFromPoly t + output <- get + cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t + return (M.Inj ident t')) cs + addOutputData $ M.Data t' cs' + +morphCons :: M.Type -> Ident -> EnvM () +morphCons expectedType ident = do + maybeD <- getInputData ident + case maybeD of + Nothing -> error $ "identifier '" ++ show ident ++ "' not found" + Just d -> do + -- Find the polymorphic type of cons + case findConsType d ident of + Nothing -> error "didn't find constructor" + Just consType -> do + -- Map polymorphic types + local (\env -> env { + polys = Map.fromList (mapTypes consType expectedType) }) $ do + morphData d + +-- TODO: detect internal errors here +findConsType :: T.Data -> Ident -> Maybe T.Type +findConsType (T.Data _ cs) name1 = foldl (\maybe (T.Inj name2 t) -> if name2 == name1 then Just t else maybe) Nothing cs + -- TODO: Change in tree so that these are the same. -- Converts Lit convertLit :: T.Lit -> M.Lit @@ -175,8 +219,9 @@ morphExp expectedType exp = case exp of else do bind <- getInputBind ident case bind of - Nothing -> + Nothing -> do -- This is a constructor + morphCons expectedType ident return $ M.EVar ident Just bind' -> do -- New bind to process @@ -217,9 +262,9 @@ newName t (T.Bind (Ident bindName, _) _ _) = newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 -- Monomorphization step -monomorphize :: T.Program -> M.Program -monomorphize (T.Program defs) = M.Program $ getDefsFromOutput - (runEnvM Map.empty (createEnv defs) monomorphize') +monomorphize :: T.Program -> O.Program +monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput + (runEnvM Map.empty (createEnv defs) monomorphize')) where monomorphize' :: EnvM () monomorphize' = do @@ -233,13 +278,30 @@ 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, - polys = Map.empty, - locals = Set.empty } +createEnv defs = Env { input = Map.fromList bindPairs, + dataDefs = Map.fromList dataPairs, + polys = Map.empty, + locals = Set.empty } where bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs + dataPairs :: [(Ident, T.Data)] + dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs -- Helper functions +-- Gets custom data declarations form defs. +getDataFromDefs :: [T.Def] -> [T.Data] +getDataFromDefs = foldl (\bs -> \case + T.DBind _ -> bs + T.DData d -> d:bs) [] + +getConsName :: T.Inj -> Ident +getConsName (T.Inj ident _) = ident + +getBindsFromDefs :: [T.Def] -> [T.Bind] +getBindsFromDefs = foldl (\bs -> \case + T.DBind b -> b:bs + T.DData _ -> bs) [] + getDefsFromOutput :: Output -> [M.Def] getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap (\case @@ -248,11 +310,6 @@ getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap Data d -> M.DData d) outputMap -getBindsFromDefs :: [T.Def] -> [T.Bind] -getBindsFromDefs = foldl (\bs -> \case - T.DBind b -> b:bs - T.DData _ -> bs) [] - getBindName :: T.Bind -> Ident getBindName (T.Bind (ident, _) _ _) = ident diff --git a/src/Monomorphizer/MorbIr.hs b/src/Monomorphizer/MorbIr.hs new file mode 100644 index 0000000..20f9496 --- /dev/null +++ b/src/Monomorphizer/MorbIr.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE LambdaCase #-} +module Monomorphizer.MorbIr where + +import Grammar.Print +import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) + +type Id = (TIR.Ident, Type) + +newtype Program = Program [Def] + deriving (Show, Ord, Eq) + +data Def = DBind Bind | DData Data + deriving (Show, Ord, Eq) + +data Data = Data Type [Inj] + deriving (Show, Ord, Eq) + +data Bind = Bind Id [Id] ExpT + deriving (Show, Ord, Eq) + +data Exp + = EVar TIR.Ident + | ELit Lit + | ELet Bind ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + | ECase ExpT [Branch] + deriving (Show, Ord, Eq) + +data Pattern + = PVar Id + | PLit (Lit, Type) + | PInj TIR.Ident [Pattern] + | PCatch + | PEnum TIR.Ident + deriving (Eq, Ord, Show) + +data Branch = Branch (Pattern, Type) ExpT + deriving (Eq, Ord, Show) + +type ExpT = (Exp, Type) + +data Inj = Inj TIR.Ident Type + deriving (Show, Ord, Eq) + +data Lit + = LInt Integer + | LChar Char + deriving (Show, Ord, Eq) + +data Type = TLit TIR.Ident | TFun Type Type | TData TIR.Ident [Type] + + deriving (Show, Ord, Eq) + +flattenType :: Type -> [Type] +flattenType (TFun t1 t2) = t1 : flattenType t2 +flattenType x = [x] + +instance Print Program where + prt i (Program sc) = prPrec i 0 $ prt 0 sc + +instance Print (Bind) where + prt i (Bind sig@(name, _) parms rhs) = + prPrec i 0 $ + concatD + [ prtSig sig + , prt 0 name + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] + +prtSig :: Id -> Doc +prtSig (name, t) = + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] + +instance Print (ExpT) where + prt i (e, t) = + concatD + [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] + +instance Print [Bind] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +prtIdPs :: Int -> [Id] -> Doc +prtIdPs i = prPrec i 0 . concatD . map (prt i) + +instance Print Exp where + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> + prPrec i 2 $ + concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> + prPrec i 1 $ + concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + ECase e branches -> + prPrec i 0 $ + concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] + +instance Print Branch 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 [Branch] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print Def where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print Data where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print Inj where + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print Pattern where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + +instance Print [Def] where + 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 _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print Lit where + prt i = \case + LInt int -> prt i int + LChar char -> prt i char + From 15c18271bac5ed8571bae76c69bd5dc4c72fbbae Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 17:53:56 +0200 Subject: [PATCH 2/3] Monomorphizer, fixed problem with type of bind --- sample-programs/mono.crf | 4 +++- src/Monomorphizer/Monomorphizer.hs | 20 +++++++++++--------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/sample-programs/mono.crf b/sample-programs/mono.crf index e682b7d..8f5fbbc 100644 --- a/sample-programs/mono.crf +++ b/sample-programs/mono.crf @@ -1,5 +1,7 @@ const x y = x; -f x = (const x 'c'); +id x = x; + +f x = (id 5); main = f 5; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6d298cd..1d1571f 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -119,7 +119,7 @@ getMonoFromPoly t = do env <- ask -- Returns the annotated bind name. -- TODO: Redundancy? btype and t should always be the same. morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = +morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = local (\env -> env { locals = Set.fromList (map fst args), polys = Map.fromList (mapTypes btype expectedType) }) $ do @@ -131,7 +131,8 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = -- Mark so that this bind will not be processed in recursive or cyclic -- function calls markBind (coerce name') - exp' <- morphExp expectedType exp + expt' <- getMonoFromPoly expt + exp' <- morphExp expt' exp -- Get monomorphic type sof args args' <- mapM convertArg args addOutputBind $ M.Bind (coerce name', expectedType) @@ -145,11 +146,10 @@ convertArg (ident, t) = do t' <- getMonoFromPoly t -- Morphs function applications, such as EApp and EAdd morphApp :: M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp morphApp expectedType (e1, t1) (e2, t2)= do - t1' <- getMonoFromPoly t1 t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 e1' <- morphExp (M.TFun t2' expectedType) e1 - return $ M.EApp (e1', t1') (e2', t2') + return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') addOutputData :: M.Data -> EnvM () addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) @@ -209,10 +209,10 @@ morphExp expectedType exp = case exp of morphExp t' exp T.ECase (exp, t) bs -> do t' <- getMonoFromPoly t - exp' <- morphExp t' exp bs' <- mapM morphBranch bs + exp' <- morphExp t' exp return $ M.ECase (exp', t') bs' - T.EVar ident@(Ident str) -> do + T.EVar ident -> do isLocal <- localExists ident if isLocal then do return $ M.EVar (coerce ident) @@ -246,7 +246,8 @@ morphPattern = \case T.PLit (lit, t) -> do t' <- getMonoFromPoly t return $ M.PLit (convertLit lit, t') T.PCatch -> return M.PCatch - T.PEnum v -> return $ M.PEnum v + -- Constructor ident + T.PEnum ident -> return $ M.PEnum ident T.PInj ident ps -> do ps' <- mapM morphPattern ps return $ M.PInj ident ps' @@ -258,8 +259,9 @@ newName t (T.Bind (Ident bindName, _) _ _) = else Ident (bindName ++ "$" ++ newName' t) where newName' :: M.Type -> String - newName' (M.TLit (Ident str)) = str - newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TLit (Ident str)) = str + newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TData (Ident str) ts) = str ++ "." ++ foldl (\s t -> s ++ "," ++ newName' t) "" ts -- Monomorphization step monomorphize :: T.Program -> O.Program From 00e23a16dd1bdef713e53bff6db7f7ba1560c5ae Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 18:58:33 +0200 Subject: [PATCH 3/3] Monomorphization of datatypes done! --- sample-programs/mono.crf | 4 +--- src/Monomorphizer/Monomorphizer.hs | 29 ++++++++++++++++------------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/sample-programs/mono.crf b/sample-programs/mono.crf index 8f5fbbc..e682b7d 100644 --- a/sample-programs/mono.crf +++ b/sample-programs/mono.crf @@ -1,7 +1,5 @@ const x y = x; -id x = x; - -f x = (id 5); +f x = (const x 'c'); main = f 5; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 1d1571f..9567bd4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -235,21 +235,24 @@ morphBranch :: T.Branch -> EnvM M.Branch morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et - e' <- morphExp et' e - p' <- morphPattern p - return $ M.Branch (p', pt') (e', et') + env <- ask + (p', newLocals) <- morphPattern (locals env) p + local (const env { locals = Set.union newLocals (locals env) }) $ do + e' <- morphExp et' e + return $ M.Branch (p', pt') (e', et') -morphPattern :: T.Pattern -> EnvM M.Pattern -morphPattern = \case +-- Morphs pattern (patter -> expression), gives the newly bound local variables. +morphPattern :: Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) +morphPattern ls = \case T.PVar (ident, t) -> do t' <- getMonoFromPoly t - return $ M.PVar (ident, t') - T.PLit (lit, t) -> do t' <- getMonoFromPoly t - return $ M.PLit (convertLit lit, t') - T.PCatch -> return M.PCatch + return (M.PVar (ident, t'), Set.insert ident ls) + T.PLit (lit, t) -> do t' <- getMonoFromPoly t + return (M.PLit (convertLit lit, t'), ls) + T.PCatch -> return (M.PCatch, ls) -- Constructor ident - T.PEnum ident -> return $ M.PEnum ident - T.PInj ident ps -> do ps' <- mapM morphPattern ps - return $ M.PInj ident ps' + T.PEnum ident -> return (M.PEnum ident, ls) + T.PInj ident ps -> do pairs <- mapM (morphPattern ls) ps + return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) -- | Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident @@ -261,7 +264,7 @@ newName t (T.Bind (Ident bindName, _) _ _) = newName' :: M.Type -> String newName' (M.TLit (Ident str)) = str newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 - newName' (M.TData (Ident str) ts) = str ++ "." ++ foldl (\s t -> s ++ "," ++ newName' t) "" ts + newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts -- Monomorphization step monomorphize :: T.Program -> O.Program