app/Main.hs

@@ -133,7 +133,7 @@ ddumpEval = whenFlag flagDDumpEval do
 
 parseProg :: RLPCOptions
           -> String
-          -> Either SrcError (Program, [SrcError])
+          -> Either SrcError (CoreProgram, [SrcError])
 parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 
 forFiles_ :: (Monad m)

rlp.cabal

@@ -14,7 +14,7 @@ extra-doc-files:    README.md
 -- extra-source-files:
 
 common warnings
-    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
+--    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
 
 library
     import:           warnings

src/Core/Examples.hs

@@ -12,7 +12,6 @@ import Core.TH
 
 -- TODO: my shitty lexer isn't inserting semicolons
 
-letrecExample :: Program
 letrecExample = [coreProg|
     pair x y f = f x y;
 
@@ -28,7 +27,6 @@ letrecExample = [coreProg|
     main = f 3 4;
 |]
 
-idExample :: Program
 idExample = [coreProg|
     main = id 3;
 |]
@@ -138,7 +136,7 @@ factorialGM = [coreProg|
     main = fac 3;
 |]
 
-corePrelude :: Module
+corePrelude :: Module Name
 corePrelude = Module (Just ("Prelude", [])) $
     -- non-primitive defs
     [coreProg|

src/Core/Parse.y

@@ -58,7 +58,7 @@ import Data.Default.Class   (def)
 
 %%
 
-Module          :: { Module }
+Module          :: { Module Name }
 Module          : module conname where Program Eof { Module (Just ($2, [])) $4 }
                 | Program Eof                      { Module Nothing $1 }
 
@@ -66,36 +66,36 @@ Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program }
+StandaloneProgram :: { Program Name }
 StandaloneProgram : Program eof                 { $1 }
 
-Program         :: { Program }
+Program         :: { Program Name }
 Program         : ScDefs                        { Program $1 }
 
-ScDefs          :: { [ScDef] }
+ScDefs          :: { [ScDef Name] }
 ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
                 | ScDef ';'                     { [$1] }
                 | ScDef                         { [$1] }
                 | {- epsilon -}                 { [] }
 
-ScDef           :: { ScDef }
+ScDef           :: { ScDef Name }
 ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
 
 ParList         :: { [Name] }
 ParList         : Var ParList                   { $1 : $2 }
                 | {- epsilon -}                 { [] }
 
-StandaloneExpr  :: { Expr }
+StandaloneExpr  :: { Expr Name }
 StandaloneExpr  : Expr eof                      { $1 }
 
-Expr            :: { Expr }
+Expr            :: { Expr Name }
 Expr            : LetExpr                       { $1 }
                 | 'λ' Binders '->' Expr         { Lam $2 $4 }
                 | Application                   { $1 }
                 | CaseExpr                      { $1 }
                 | Expr1                         { $1 }
 
-LetExpr         :: { Expr }
+LetExpr         :: { Expr Name }
 LetExpr         : let    '{'   Bindings '}'    in Expr { Let NonRec $3 $6 }
                 | letrec '{'   Bindings '}'    in Expr { Let Rec $3 $6 }
 
@@ -103,48 +103,48 @@ Binders         :: { [Name] }
 Binders         : Var Binders                  { $1 : $2 }
                 | Var                          { [$1] }
 
-Application     :: { Expr }
+Application     :: { Expr Name }
 Application     : Expr1 AppArgs                 { foldl' App $1 $2 }
 
 -- TODO: Application can probably be written as a single rule, without AppArgs
-AppArgs         :: { [Expr] }
+AppArgs         :: { [Expr Name] }
 AppArgs         : Expr1 AppArgs                 { $1 : $2 }
                 | Expr1                         { [$1] }
 
-CaseExpr        :: { Expr }
+CaseExpr        :: { Expr Name }
 CaseExpr        : case Expr of '{' Alters '}'   { Case $2 $5 }
 
-Alters          :: { [Alter] }
+Alters          :: { [Alter Name] }
 Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter ';'                     { [$1] }
                 | Alter                         { [$1] }
 
-Alter           :: { Alter }
+Alter           :: { Alter Name }
-Alter           : litint ParList '->' Expr      { Alter $1 $2 $4 }
+Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 
-Expr1           :: { Expr }
+Expr1           :: { Expr Name }
-Expr1           : litint                        { IntE $1 }
+Expr1           : litint                        { LitE $ IntL $1 }
-                | Id                            { Var $1 }
+                | Id                            { Var (Name $1) }
                 | PackCon                       { $1 }
                 | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
-ExprPragma      :: { Expr }
+ExprPragma      :: { Expr Name }
 ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
 
 Words           :: { [String] }
 Words           : word Words                    { $1 : $2 }
                 | word                          { [$1] }
 
-PackCon         :: { Expr }
+PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
-Bindings        :: { [Binding] }
+Bindings        :: { [Binding Name] }
 Bindings        : Binding ';' Bindings          { $1 : $3 }
                 | Binding ';'                   { [$1] }
                 | Binding                       { [$1] }
 
-Binding         :: { Binding }
+Binding         :: { Binding Name }
 Binding         : Var '=' Expr                  { $1 := $3 }
 
 Id              :: { Name }
@@ -169,7 +169,7 @@ parseError (Located y x l _ : _) = addFatal err
             , _errDiagnostic = SrcErrParse
             }
 
-parseTmp :: IO Module
+parseTmp :: IO (Module Name)
 parseTmp = do
     s <- readFile "/tmp/t.hs"
     case parse s of
@@ -178,7 +178,7 @@ parseTmp = do
     where
         parse = evalRLPC def . (lexCore >=> parseCore)
 
-exprPragma :: [String] -> RLPC SrcError Expr
+exprPragma :: [String] -> RLPC SrcError (Expr Name)
 exprPragma ("AST" : e) = astPragma e
 exprPragma _           = addFatal err
     where err = SrcError
@@ -187,7 +187,7 @@ exprPragma _           = addFatal err
             , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
             }
 
-astPragma :: [String] -> RLPC SrcError Expr
+astPragma :: [String] -> RLPC SrcError (Expr Name)
 astPragma = pure . read . unwords
 
 }

src/Core/Rename.hs

@@ -0,0 +1,11 @@
+module Core.Rename
+    ( renameCore
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Syntax
+----------------------------------------------------------------------------------
+
+renameCore :: Program Name -> Program Unique
+renameCore = undefined
+

src/Core/Syntax.hs

@@ -5,8 +5,11 @@ Description : Core ASTs and the like
 {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
 module Core.Syntax
     ( Expr(..)
+    , Id(..)
+    , Literal(..)
     , pattern (:$)
     , Binding(..)
+    , AltCon(..)
     , pattern (:=)
     , Rec(..)
     , Alter(..)
@@ -15,6 +18,7 @@ module Core.Syntax
     , ScDef(..)
     , Module(..)
     , Program(..)
+    , CoreProgram
     , bindersOf
     , rhssOf
     , isAtomic
@@ -31,106 +35,68 @@ import Data.String
 import Language.Haskell.TH.Syntax   (Lift)
 ----------------------------------------------------------------------------------
 
-data Expr = Var Name
+data Expr b = Var Id
             | Con Tag Int -- Con Tag Arity
-          | Let Rec [Binding] Expr
+            | Case (Expr b) [Alter b]
-          | Case Expr [Alter]
+            | Lam [b] (Expr b)
-          | Lam [Name] Expr
+            | Let Rec [Binding b] (Expr b)
-          | App Expr Expr
+            | App (Expr b) (Expr b)
-          | IntE Int
+            | LitE Literal
-          deriving (Show, Read, Lift, Eq)
+            deriving (Show, Read, Lift)
+
+data Id = Name Name
+    deriving (Show, Read, Lift)
 
 infixl 2 :$
-pattern (:$) :: Expr -> Expr -> Expr
+pattern (:$) :: Expr b  -> Expr b  -> Expr b 
 pattern f :$ x = App f x
 
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
-data Binding = Binding Name Expr
+data Binding b = Binding b (Expr b)
-    deriving (Show, Read, Lift, Eq)
+    deriving (Show, Read, Lift)
 
 infixl 1 :=
-pattern (:=) :: Name -> Expr -> Binding
+pattern (:=) :: b -> (Expr b) -> (Binding b)
 pattern k := v = Binding k v
+data Alter b = Alter AltCon [b] (Expr b)
+    deriving (Show, Read, Lift)
 
 data Rec = Rec
          | NonRec
          deriving (Show, Read, Eq, Lift)
 
-data Alter = Alter Tag [Name] Expr
+data AltCon = AltData Tag
-    deriving (Show, Read, Lift, Eq)
+            | AltLiteral Literal
+            | Default
+            deriving (Show, Read, Lift)
+
+data Literal = IntL Int
+    deriving (Show, Read, Lift)
 
 type Name = String
 type Tag = Int
 
-data ScDef = ScDef Name [Name] Expr
+data ScDef b = ScDef b [b] (Expr b)
-    deriving (Show, Lift, Eq)
-
-data Module = Module (Maybe (Name, [Name])) Program
     deriving (Show, Lift)
 
-newtype Program = Program [ScDef]
+data Module b = Module (Maybe (Name, [Name])) (Program b)
     deriving (Show, Lift)
 
-instance IsString Expr where
+newtype Program b = Program [ScDef b]
-    fromString = Var
+    deriving (Show, Lift)
+
+type CoreProgram = Program Name
+
+instance IsString (Expr b) where
+    fromString = Var . Name
 
 ----------------------------------------------------------------------------------
 
-instance Pretty Program where
+instance Semigroup (Program b) where
-    -- TODO: module header
+    (<>) = coerce $ (<>) @[ScDef b] 
-    prettyPrec (Program ss) _ = mconcat $ intersperse "\n\n" $ fmap pretty ss
 
-instance Pretty ScDef where
+instance Monoid (Program b) where
-    prettyPrec (ScDef n as e) _ =
-        mconcat (intersperse " " $ fmap IStr (n:as))
-        <> " = " <> pretty e <> IBreak
-
-instance Pretty Expr where
-    prettyPrec (Var k)      = withPrec maxBound $ IStr k
-    prettyPrec (IntE n)     = withPrec maxBound $ iShow n
-    prettyPrec (Con t a)    = withPrec maxBound $
-        "Pack{" <> iShow t <> " " <> iShow a <> "}"
-    prettyPrec (Let r bs e) = withPrec 0 $
-        IStr (if r == Rec then "letrec " else "let ")
-        <> binds <> IBreak
-        <> "in " <> pretty e
-        where
-            binds = mconcat (f <$> init bs)
-                 <> IIndent (pretty $ last bs)
-            f b = IIndent $ pretty b <> IBreak
-    prettyPrec (Lam ns e)   = withPrec 0 $ 
-        IStr "λ" <> binds <> " -> " <> pretty e
-        where
-            binds = fmap IStr ns & intersperse " " & mconcat
-    prettyPrec (Case e as)   = withPrec 0 $
-            "case " <> IIndent (pretty e <> " of" <> IBreak <> alts)
-        where
-            -- TODO: don't break on last alt
-            alts = mconcat $ fmap palt as
-            palt x = IIndent $ pretty x <> IBreak
-    prettyPrec (App f x) = \p -> bracketPrec 0 p $
-        case f of
-            -- application is left-associative; don't increase prec if the
-            -- expression being applied is itself an application
-            (_:$_) -> precPretty       p  f <> " " <> precPretty (succ p) x
-            _      -> precPretty (succ p) f <> " " <> precPretty (succ p) x
-
-instance Pretty Alter where
-    prettyPrec (Alter t bs e) = withPrec 0 $
-            "<" <> IStr (show t) <> "> " <> binds <> " -> " <> pretty e
-        where
-            binds = mconcat $ intersperse " " (fmap IStr bs)
-
-instance Pretty Binding where
-    prettyPrec (k := v) = withPrec 0 $ IStr k <> " = " <> precPretty 0 v
-
-----------------------------------------------------------------------------------
-
-instance Semigroup Program where
-    (<>) = coerce $ (<>) @[ScDef] 
-
-instance Monoid Program where
     mempty = Program []
 
 ----------------------------------------------------------------------------------
@@ -141,16 +107,17 @@ bindersOf = fmap fst
 rhssOf :: [(Name, b)] -> [b]
 rhssOf = fmap snd
 
-isAtomic :: Expr -> Bool
+isAtomic :: Expr b -> Bool
 isAtomic (Var _)  = True
+isAtomic (LitE _) = True
 isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
 -- TODO: export list awareness
-insertModule :: Module -> Program -> Program
+insertModule :: (Module b) -> (Program b) -> (Program b)
 insertModule (Module _ m) p = p <> m
 
-extractProgram :: Module -> Program
+extractProgram :: (Module b) -> (Program b)
 extractProgram (Module _ p) = p
 

src/Core2Core.hs

@@ -0,0 +1,14 @@
+module Core2Core
+    (
+    )
+    where
+----------------------------------------------------------------------------------
+import Core.Syntax
+----------------------------------------------------------------------------------
+
+core2core :: Program -> Program
+core2core = undefined
+
+floatNonStrictCase :: Expr -> Expr
+floatNonStrictCase (Case e as) = Case e ()
+

src/GM.hs

@@ -30,6 +30,19 @@ import Debug.Trace
 import Core
 ----------------------------------------------------------------------------------
 
+hdbgProg = undefined
+evalProg = undefined
+
+data Node = NNum Int
+          | NAp Addr Addr
+          | NInd Addr
+          | NUninitialised
+          | NConstr Tag [Addr] -- NConstr Tag Components
+          | NMarked Node
+          deriving (Show, Eq)
+
+{-
+
 data GmState = GmState
     { _gmCode   :: Code
     , _gmStack  :: Stack
@@ -596,7 +609,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 f (NameKey n, _) = Just n
                 f _              = Nothing
 
-        compileC _ (IntE n)  = [PushInt n]
+        compileC _ (LitE l)  = compileCL l
 
         -- >> [ref/compileC]
         compileC g (App f x) = compileC g x
@@ -640,10 +653,16 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
 
         compileC _ _ = error "yet to be implemented!"
 
+        compileCL :: Literal -> Code
+        compileCL (IntL n) = [PushInt n]
+
+        compileEL :: Literal -> Code
+        compileEL (IntL n) = [PushInt n]
+
         -- compile an expression in a strict context such that a pointer to the
         -- expression is left on top of the stack in WHNF
         compileE :: Env -> Expr -> Code
-        compileE _ (IntE n) = [PushInt n]
+        compileE _ (LitE l) = compileEL l
         compileE g (Let NonRec bs e) =
                 -- we use compileE instead of compileC
                 mconcat binders <> compileE g' e <> [Slide d]
@@ -921,3 +940,5 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
+
+--}

src/TI.hs

@@ -28,6 +28,10 @@ import Core.Examples
 import Core
 ----------------------------------------------------------------------------------
 
+hdbgProg = undefined
+
+{-
+
 data TiState = TiState Stack Dump TiHeap Env Stats
     deriving Show
 
@@ -611,3 +615,5 @@ gc st@(TiState s d h g sts) = TiState s d h' g sts
         marked = h & appEndo (foldMap Endo $ markFrom <$> as)
         h' = scanHeap marked
 
+--}
+