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

dummy monomorphizer complete

Browse source
This commit is contained in:
sebastian 2023-03-24 22:03:43 +01:00
parent 7e246a94e5
commit accbd4eea6
2 changed files with 33 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

53
src/Monomorphizer/Monomorphizer.hs
View file

@ -1,14 +1,12 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Monomorphizer.Monomorphizer (monomorphize) where module Monomorphizer.Monomorphizer (monomorphize) where
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Grammar.Abs (Constructor (..), Ident (..))
import qualified Grammar.Abs as GA import Monomorphizer.MonomorphizerIr qualified as M
import qualified Monomorphizer.MonomorphizerIr as M import TypeChecker.TypeCheckerIr qualified as T
import qualified TypeChecker.TypeCheckerIr as T
monomorphize :: T.Program -> M.Program monomorphize :: T.Program -> M.Program
monomorphize (T.Program ds) = M.Program $ monoDefs ds monomorphize (T.Program ds) = M.Program $ monoDefs ds
@ -18,17 +16,20 @@ monoDefs = map monoDef
monoDef :: T.Def -> M.Def monoDef :: T.Def -> M.Def
monoDef (T.DBind bind) = M.DBind $ monoBind bind monoDef (T.DBind bind) = M.DBind $ monoBind bind
monoDef (T.DData d) = M.DData $ monoData d monoDef (T.DData d) = M.DData $ monoData d
monoBind :: T.Bind -> M.Bind monoBind :: T.Bind -> M.Bind
monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t)
monoData :: T.Data -> M.Data monoData :: T.Data -> M.Data
monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (Ident id)) [] monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs)
monoConstructor :: T.Constructor -> M.Constructor
monoConstructor (T.Constructor (T.Ident i) t) = M.Constructor (M.Ident i) (monoType t)
monoExpr :: T.Exp -> M.Exp monoExpr :: T.Exp -> M.Exp
monoExpr = \case monoExpr = \case
T.EId (T.Ident i) -> M.EId (Ident i) T.EId (T.Ident i) -> M.EId (M.Ident i)
T.ELit lit -> M.ELit $ monoLit lit T.ELit lit -> M.ELit $ monoLit lit
T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt)
T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2)
@ -36,20 +37,19 @@ monoExpr = \case
T.EAbs _i _expt -> error "BUG" T.EAbs _i _expt -> error "BUG"
T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs)
monoAbsType :: GA.Type -> M.Type monoAbsType :: T.Type -> M.Type
monoAbsType (GA.TLit u) = M.TLit (coerce u) monoAbsType (T.TLit u) = M.TLit (coerce u)
monoAbsType (GA.TVar _v) = M.TLit "Int" monoAbsType (T.TVar _v) = M.TLit "Int"
monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" monoAbsType (T.TAll _v _t) = error "NOT ALL TYPES"
monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (T.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2)
monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) monoAbsType (T.TData _ _) = error "NOT INDEXED TYPES"
monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES"
monoType :: T.Type -> M.Type monoType :: T.Type -> M.Type
monoType (T.TAll _ t) = monoType t monoType (T.TAll _ t) = monoType t
monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" monoType (T.TVar (T.MkTVar i)) = M.TLit "Int"
monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) monoType (T.TLit (T.Ident i)) = M.TLit (M.Ident i)
monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2)
monoType (T.TData (T.Ident n) t) = M.TLit (Ident (n ++ concatMap show t)) monoType (T.TData (T.Ident n) t) = M.TLit (M.Ident (n ++ concatMap show t))
monoexpt :: T.ExpT -> M.ExpT monoexpt :: T.ExpT -> M.ExpT
monoexpt (e, t) = (monoExpr e, monoType t) monoexpt (e, t) = (monoExpr e, monoType t)
@ -58,7 +58,7 @@ monoId :: T.Id -> M.Id
monoId (n, t) = (coerce n, monoType t) monoId (n, t) = (coerce n, monoType t)
monoLit :: T.Lit -> M.Lit monoLit :: T.Lit -> M.Lit
monoLit (T.LInt i) = M.LInt i monoLit (T.LInt i) = M.LInt i
monoLit (T.LChar c) = M.LChar c monoLit (T.LChar c) = M.LChar c
monoInjs :: [T.Branch] -> [M.Branch] monoInjs :: [T.Branch] -> [M.Branch]
@ -68,8 +68,9 @@ monoInj :: T.Branch -> M.Branch
monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt)
monoInit :: T.Pattern -> M.Pattern monoInit :: T.Pattern -> M.Pattern
monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t)
monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t)
monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps)
monoInit (T.PEnum id) = undefined -- DO NOT DO THIS FOR REAL THOUGH
monoInit T.PCatch = M.PCatch monoInit (T.PEnum (T.Ident i)) = M.PInj (M.Ident i) []
monoInit T.PCatch = M.PCatch

12
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -1,8 +1,8 @@
module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where
import Grammar.Abs (Ident (..), UIdent) import Grammar.Abs (Ident (..), UIdent)
import qualified Grammar.Abs as GA (Ident (..)) import Grammar.Abs qualified as GA (Ident (..))
import qualified TypeChecker.TypeCheckerIr as RE import TypeChecker.TypeCheckerIr qualified as RE
type Id = (Ident, Type) type Id = (Ident, Type)
@ -27,7 +27,7 @@ data Exp
| ECase ExpT [Branch] | ECase ExpT [Branch]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch | PEnum Ident
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data Branch = Branch (Pattern, Type) ExpT data Branch = Branch (Pattern, Type) ExpT
@ -35,7 +35,7 @@ data Branch = Branch (Pattern, Type) ExpT
type ExpT = (Exp, Type) type ExpT = (Exp, Type)
data Constructor = Constructor Ident [(Ident, Type)] data Constructor = Constructor Ident Type
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Lit data Lit
@ -48,4 +48,4 @@ data Type = TLit Ident | TFun Type Type
flattenType :: Type -> [Type] flattenType :: Type -> [Type]
flattenType (TFun t1 t2) = t1 : flattenType t2 flattenType (TFun t1 t2) = t1 : flattenType t2
flattenType x = [x] flattenType x = [x]