Started working on a Case Desugar phase.
This commit is contained in:
Samuel Hammersberg
parent
7d2a0e60d8
commit
b0ec5a2333
2 changed files with 309 additions and 0 deletions
83
src/CaseDesugar/CaseDesugar.hs
Normal file
83
src/CaseDesugar/CaseDesugar.hs
Normal file
|
|
@ -0,0 +1,83 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
|
module CaseDesugar.CaseDesugar (desuga) where
|
||||||
|
|
||||||
|
import CaseDesugar.CaseDesugarIr qualified as CIR
|
||||||
|
import TypeChecker.TypeCheckerIr qualified as TIR
|
||||||
|
|
||||||
|
desuga :: TIR.Program -> CIR.Program
|
||||||
|
desuga (TIR.Program x) = CIR.Program $ desugaDef <$> x
|
||||||
|
|
||||||
|
desugaDef :: TIR.Def -> CIR.Def
|
||||||
|
desugaDef (TIR.DBind bin@TIR.Bind{}) = CIR.DBind $ desugaBind bin
|
||||||
|
desugaDef (TIR.DData dat@TIR.Data{}) = CIR.DData $ desugaData dat
|
||||||
|
|
||||||
|
desugaData :: TIR.Data -> CIR.Data
|
||||||
|
desugaData (TIR.Data t injs) = CIR.Data (desugaType t) (desugaInj <$> injs)
|
||||||
|
|
||||||
|
desugaType :: TIR.Type -> CIR.Type
|
||||||
|
desugaType (TIR.TLit (TIR.Ident s)) = CIR.TLit (CIR.Ident s)
|
||||||
|
desugaType (TIR.TVar tv) = CIR.TVar (desugaTVar tv)
|
||||||
|
desugaType (TIR.TData (TIR.Ident s) ts) = CIR.TData (CIR.Ident s) (desugaType <$> ts)
|
||||||
|
desugaType (TIR.TFun t1 t2) = CIR.TFun (desugaType t1) (desugaType t2)
|
||||||
|
desugaType (TIR.TAll _ t1) = desugaType t1
|
||||||
|
|
||||||
|
desugaTVar :: TIR.TVar -> CIR.TVar
|
||||||
|
desugaTVar (TIR.MkTVar (TIR.Ident s)) = CIR.MkTVar (CIR.Ident s)
|
||||||
|
|
||||||
|
desugaInj :: TIR.Inj -> CIR.Inj
|
||||||
|
desugaInj (TIR.Inj (TIR.Ident s) t) = CIR.Inj (CIR.Ident s) (desugaType t)
|
||||||
|
|
||||||
|
desugaId :: TIR.Id -> CIR.Id
|
||||||
|
desugaId (TIR.Ident s, t) = (CIR.Ident s, desugaType t)
|
||||||
|
|
||||||
|
desugaBind :: TIR.Bind -> CIR.Bind
|
||||||
|
desugaBind (TIR.Bind id args exp) =
|
||||||
|
CIR.Bind (desugaId id) (desugaId <$> args) (desugaExpT exp)
|
||||||
|
|
||||||
|
desugaExpT :: TIR.ExpT -> CIR.ExpT
|
||||||
|
desugaExpT (exp, t) = (desugaExp exp, desugaType t)
|
||||||
|
|
||||||
|
desugaExp :: TIR.Exp -> CIR.Exp
|
||||||
|
desugaExp (TIR.EVar (TIR.Ident s)) = CIR.EVar (CIR.Ident s)
|
||||||
|
desugaExp (TIR.EInj (TIR.Ident s)) = CIR.EInj (CIR.Ident s)
|
||||||
|
desugaExp (TIR.ELit lit) = CIR.ELit lit
|
||||||
|
desugaExp (TIR.ELet b e) = CIR.ELet (desugaBind b) (desugaExpT e)
|
||||||
|
desugaExp (TIR.EApp e1 e2) = CIR.EApp (desugaExpT e1) (desugaExpT e2)
|
||||||
|
desugaExp (TIR.EAdd e1 e2) = CIR.EAdd (desugaExpT e1) (desugaExpT e2)
|
||||||
|
desugaExp (TIR.EAbs (TIR.Ident s) e) = CIR.EAbs (CIR.Ident s) (desugaExpT e)
|
||||||
|
desugaExp (TIR.ECase e branches) = CIR.ECase (desugaExpT e) (desugaBranches branches)
|
||||||
|
|
||||||
|
desugaBranches :: [TIR.Branch] -> [CIR.Branch]
|
||||||
|
desugaBranches bs = do
|
||||||
|
let injections = filter (\case (TIR.Branch (TIR.PInj{}, _) _) -> True; _ -> False) bs
|
||||||
|
let patterns = filter (\case (TIR.Branch (TIR.PInj{}, _) _) -> True; _ -> False) bs
|
||||||
|
undefined
|
||||||
|
|
||||||
|
desugaBranch :: TIR.Branch -> CIR.Branch
|
||||||
|
desugaBranch (TIR.Branch (TIR.PInj (TIR.Ident s) ps, pt) e) = do
|
||||||
|
undefined
|
||||||
|
desugaBranch (TIR.Branch (p, pt) e) = do
|
||||||
|
CIR.Branch
|
||||||
|
( case p of
|
||||||
|
TIR.PVar id -> (CIR.PVar (desugaId id), desugaType pt)
|
||||||
|
TIR.PLit (lit, t) -> (CIR.PLit (lit, desugaType t), desugaType pt)
|
||||||
|
TIR.PCatch -> (CIR.PCatch, desugaType pt)
|
||||||
|
TIR.PEnum (TIR.Ident s) -> (CIR.PEnum (CIR.Ident s), desugaType pt)
|
||||||
|
)
|
||||||
|
(desugaExpT e)
|
||||||
|
|
||||||
|
{-
|
||||||
|
case (Tupli 5 5) of
|
||||||
|
Tupli 6 5 => 1
|
||||||
|
Tupli _ x => 3
|
||||||
|
x => 1
|
||||||
|
===
|
||||||
|
case (Tupli 5 5) of
|
||||||
|
Tupli x y => case x of
|
||||||
|
6 => case y of
|
||||||
|
5 => 1
|
||||||
|
x => 3
|
||||||
|
_ => case y of
|
||||||
|
x => 3
|
||||||
|
-}
|
||||||
226
src/CaseDesugar/CaseDesugarIr.hs
Normal file
226
src/CaseDesugar/CaseDesugarIr.hs
Normal file
|
|
@ -0,0 +1,226 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
|
||||||
|
module CaseDesugar.CaseDesugarIr (
|
||||||
|
module Grammar.Abs,
|
||||||
|
module CaseDesugar.CaseDesugarIr,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.String (IsString)
|
||||||
|
import Grammar.Abs (Lit (..))
|
||||||
|
import Grammar.Print
|
||||||
|
import Prelude
|
||||||
|
import Prelude qualified as C (Eq, Ord, Read, Show)
|
||||||
|
|
||||||
|
newtype Program' t = Program [Def' t]
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Def' t
|
||||||
|
= DBind (Bind' t)
|
||||||
|
| DData (Data' t)
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Type
|
||||||
|
= TLit Ident
|
||||||
|
| TVar TVar
|
||||||
|
| TData Ident [Type]
|
||||||
|
| TFun Type Type
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Data' t = Data t [Inj' t]
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Inj' t = Inj Ident t
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
newtype Ident = Ident String
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read, IsString)
|
||||||
|
|
||||||
|
data Pattern' t
|
||||||
|
= PVar (Id' t) -- TODO should be Ident
|
||||||
|
| PLit (Lit, t) -- TODO should be Lit
|
||||||
|
| PCatch
|
||||||
|
| PEnum Ident
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Exp' t
|
||||||
|
= EVar Ident
|
||||||
|
| EInj Ident
|
||||||
|
| ELit Lit
|
||||||
|
| ELet (Bind' t) (ExpT' t)
|
||||||
|
| EApp (ExpT' t) (ExpT' t)
|
||||||
|
| EAdd (ExpT' t) (ExpT' t)
|
||||||
|
| EAbs Ident (ExpT' t)
|
||||||
|
| ECase (ExpT' t) [Branch' t]
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
newtype TVar = MkTVar Ident
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
type Id' t = (Ident, t)
|
||||||
|
type ExpT' t = (Exp' t, t)
|
||||||
|
|
||||||
|
data Bind' t = Bind (Id' t) [Id' t] (ExpT' t)
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
data Branch' t = Branch (Pattern' t, t) (ExpT' t)
|
||||||
|
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||||
|
|
||||||
|
instance Print Ident where
|
||||||
|
prt _ (Ident s) = doc $ showString s
|
||||||
|
|
||||||
|
instance Print t => Print (Program' t) where
|
||||||
|
prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||||
|
|
||||||
|
instance Print t => Print (Bind' t) 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 :: Print t => Id' t -> Doc
|
||||||
|
prtSig (name, t) =
|
||||||
|
concatD
|
||||||
|
[ prt 0 name
|
||||||
|
, doc $ showString ":"
|
||||||
|
, prt 0 t
|
||||||
|
, doc $ showString ";"
|
||||||
|
]
|
||||||
|
|
||||||
|
instance Print t => Print (ExpT' t) where
|
||||||
|
prt i (e, t) =
|
||||||
|
concatD
|
||||||
|
[ doc $ showString "("
|
||||||
|
, prt i e
|
||||||
|
, doc $ showString ","
|
||||||
|
, prt i t
|
||||||
|
, doc $ showString ")"
|
||||||
|
]
|
||||||
|
|
||||||
|
instance Print t => Print [Bind' t] where
|
||||||
|
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
|
||||||
|
prtIdPs i = prPrec i 0 . concatD . map (prt i)
|
||||||
|
|
||||||
|
instance Print t => Print (Id' t) where
|
||||||
|
prt i (name, t) =
|
||||||
|
concatD
|
||||||
|
[ doc $ showString "("
|
||||||
|
, prt i name
|
||||||
|
, doc $ showString ","
|
||||||
|
, prt i t
|
||||||
|
, doc $ showString ")"
|
||||||
|
]
|
||||||
|
|
||||||
|
instance Print t => Print (Exp' t) where
|
||||||
|
prt i = \case
|
||||||
|
EVar name -> prPrec i 3 $ prt 0 name
|
||||||
|
EInj 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
|
||||||
|
]
|
||||||
|
EAbs v e ->
|
||||||
|
prPrec i 0 $
|
||||||
|
concatD
|
||||||
|
[ doc $ showString "\\"
|
||||||
|
, prt 0 v
|
||||||
|
, doc $ showString "."
|
||||||
|
, prt 0 e
|
||||||
|
]
|
||||||
|
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 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 _ (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])
|
||||||
|
DData data_ -> prPrec i 0 (concatD [prt 0 data_])
|
||||||
|
|
||||||
|
instance Print t => Print (Data' t) 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 t => Print (Inj' t) where
|
||||||
|
prt i = \case
|
||||||
|
Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_])
|
||||||
|
|
||||||
|
instance Print t => Print (Pattern' t) 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])
|
||||||
|
|
||||||
|
instance Print t => Print [Def' t] 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])
|
||||||
|
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])
|
||||||
|
|
||||||
|
instance Print TVar where
|
||||||
|
prt i (MkTVar ident) = prt i ident
|
||||||
|
|
||||||
|
type Program = Program' Type
|
||||||
|
type Def = Def' Type
|
||||||
|
type Data = Data' Type
|
||||||
|
type Bind = Bind' Type
|
||||||
|
type Branch = Branch' Type
|
||||||
|
type Pattern = Pattern' Type
|
||||||
|
type Inj = Inj' Type
|
||||||
|
type Exp = Exp' Type
|
||||||
|
type ExpT = ExpT' Type
|
||||||
|
type Id = Id' Type
|
||||||
|
pattern DBind' id vars expt = DBind (Bind id vars expt)
|
||||||
|
pattern DData' typ injs = DData (Data typ injs)
|
||||||
Loading…
Add table
Add a link
Reference in a new issue