diff --git a/Grammar.cf b/Grammar.cf index 35c3a56..46795f2 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -13,8 +13,10 @@ DBind. Def ::= Bind; DSig. Def ::= Sig; DData. Def ::= Data; -Sig. Sig ::= LIdent ":" Type; -Bind. Bind ::= LIdent [LIdent] "=" Exp; +internal Sig. Sig ::= LIdent ":" Type; + SigS. Sig ::= VarName ":" Type; +internal Bind. Bind ::= LIdent [LIdent] "=" Exp; + BindS. Bind ::= VarName [LIdent] "=" Exp; ------------------------------------------------------------------------------- -- * Types @@ -42,15 +44,22 @@ Inj. Inj ::= UIdent ":" Type ; -- * Expressions ------------------------------------------------------------------------------- -EVar. Exp4 ::= LIdent; -EInj. Exp4 ::= UIdent; -ELit. Exp4 ::= Lit; -EApp. Exp3 ::= Exp3 Exp4; -EAdd. Exp2 ::= Exp2 "+" Exp3; -ELet. Exp1 ::= "let" Bind "in" Exp1; -EAbs. Exp1 ::= "\\" LIdent "." Exp1; -ECase. Exp1 ::= "case" Exp "of" "{" [Branch] "}"; -EAnn. Exp ::= Exp1 ":" Type; +internal EVar. Exp4 ::= LIdent; + EVarS. Exp4 ::= VarName ; + EInj. Exp4 ::= UIdent; + ELit. Exp4 ::= Lit; + EApp. Exp3 ::= Exp3 Exp4; + EAdd. Exp2 ::= Exp2 "+" Exp3; + ELet. Exp1 ::= "let" Bind "in" Exp1; + EAbs. Exp1 ::= "\\" LIdent "." Exp1; + ECase. Exp1 ::= "case" Exp "of" "{" [Branch] "}"; + EAnn. Exp ::= Exp1 ":" Type; + +VSymbol. VarName ::= "." Symbol; +VIdent. VarName ::= LIdent; + +infixSymbol. Exp2 ::= Exp2 Symbol Exp3 ; +define infixSymbol e1 vn e3 = EApp (EApp (EVarS (VSymbol vn)) e1) e3; ------------------------------------------------------------------------------- -- * LITERALS @@ -93,6 +102,7 @@ coercions Type 1 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; +token Symbol (["@#%^&*_-+=|?/<>,•"]+) ; comment "--"; comment "{-" "-}"; diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index a2a5ffd..14abef1 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -5,27 +5,68 @@ module Desugar.Desugar where import Data.Function (on) import Grammar.Abs +{- + +The entire module should never have any catch all pattern matches as that +will disble warnings for when the grammar is expanded. + +-} + desugar :: Program -> Program desugar (Program defs) = Program (map desugarDef defs) +desugarVarName :: VarName -> LIdent +desugarVarName (VSymbol (Symbol i)) = LIdent i +desugarVarName (VIdent i) = i + desugarDef :: Def -> Def desugarDef = \case DBind b -> DBind (desugarBind b) - DSig sig -> DSig sig - DData d -> DData d + DSig sig -> DSig (desugarSig sig) + DData d -> DData (desugarData d) desugarBind :: Bind -> Bind +desugarBind (BindS name args e) = Bind (desugarVarName name) args (desugarExp e) desugarBind (Bind name args e) = Bind name args (desugarExp e) +desugarSig :: Sig -> Sig +desugarSig (SigS ident typ) = Sig (desugarVarName ident) (desugarType typ) +desugarSig (Sig ident typ) = Sig ident (desugarType typ) + +desugarData :: Data -> Data +desugarData (Data typ injs) = Data (desugarType typ) (map desugarInj injs) + +desugarType :: Type -> Type +desugarType t = t + +desugarInj :: Inj -> Inj +desugarInj (Inj ident typ) = Inj ident (desugarType typ) + desugarExp :: Exp -> Exp desugarExp = \case - EApp e1 e2 -> (EApp `on` desugarExp) e1 e2 - EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2 + EApp e1 e2 -> EApp (desugarExp e1) (desugarExp e2) + EAdd e1 e2 -> EAdd (desugarExp e1) (desugarExp e2) EAbs i e -> EAbs i (desugarExp e) ELet b e -> ELet (desugarBind b) (desugarExp e) ECase e br -> ECase (desugarExp e) (map desugarBranch br) EAnn e t -> EAnn (desugarExp e) t - e -> e + EVarS (VSymbol (Symbol symb)) -> EVar (LIdent symb) + EVarS (VIdent ident) -> EVar ident + EVar i -> EVar i + ELit l -> ELit l + EInj i -> EInj i desugarBranch :: Branch -> Branch -desugarBranch (Branch p e) = Branch p (desugarExp e) +desugarBranch (Branch p e) = Branch (desugarPattern p) (desugarExp e) + +desugarPattern :: Pattern -> Pattern +desugarPattern = \case + PVar ident -> PVar ident + PLit lit -> PLit (desugarLit lit) + PCatch -> PCatch + PEnum ident -> PEnum ident + PInj ident patterns -> PInj ident (map desugarPattern patterns) + +desugarLit :: Lit -> Lit +desugarLit (LInt i) = LInt i +desugarLit (LChar c) = LChar c