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

Added some missing functionality to the dummy monomorphizer.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-24 10:57:21 +01:00
parent fc60112877
commit 30a79f34af
2 changed files with 18 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/Monomorphizer/Monomorphizer.hs
View file

@ -5,6 +5,7 @@ module Monomorphizer.Monomorphizer (monomorphize) where
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Grammar.Abs (Constructor (..), Ident (..), import Grammar.Abs (Constructor (..), Ident (..),
Indexed (..)) Indexed (..))
import qualified Grammar.Abs as GA
import qualified Monomorphizer.MonomorphizerIr as M import qualified Monomorphizer.MonomorphizerIr as M
import qualified TypeChecker.TypeCheckerIr as T import qualified TypeChecker.TypeCheckerIr as T
@ -22,7 +23,7 @@ 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.Constructor monoData :: T.Data -> M.Constructor
monoData (T.Data (Indexed n _) cons) = undefined-- M.Constructor n (map (\(Constructor n t) -> (n, monoType t)) cons) monoData (T.Data (Indexed n _) cons) = M.Constructor n (map (\(Constructor n t) -> (n, monoAbsType t)) cons)
monoExpr :: T.Exp -> M.Exp monoExpr :: T.Exp -> M.Exp
monoExpr = \case monoExpr = \case
@ -31,14 +32,24 @@ monoExpr = \case
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)
T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2) T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2)
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 (GA.TLit u) = M.TLit (coerce u)
monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES"
monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES"
monoAbsType (GA.TIndexed _i) = error "NOT INDEXED TYPES"
monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS"
monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2)
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)) = error "NOT POLYMORPHIC TYPES" monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES"
monoType (T.TLit i) = M.TLit i monoType (T.TLit i) = M.TLit 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.TIndexed _) = error "Not sure what this is"
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,3 +69,4 @@ monoInj (T.Inj (init, t) expt) = M.Injection (monoInit init, monoType t) (monoex
monoInit :: T.Init -> M.Init monoInit :: T.Init -> M.Init
monoInit = id monoInit = id

4
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -40,3 +40,7 @@ data Lit
data Type = TLit Ident | TFun Type Type data Type = TLit Ident | TFun Type Type
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
flattenType :: Type -> [Type]
flattenType (TFun t1 t2) = t1 : flattenType t2
flattenType x = [x]