oh boy (pack)

app/Main.hs

@@ -44,7 +44,7 @@ options = RLPCOptions
         <> value EvaluatorGM
         <> help "the intermediate layer used to model evaluation"
         )
-    <*> some (argument str (metavar "FILES..."))
+    <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -62,6 +62,7 @@ debugFlagReader :: ReadM DebugFlag
 debugFlagReader = maybeReader $ \case
     "dump-eval"  -> Just DDumpEval
     "dump-opts"  -> Just DDumpOpts
+    "dump-ast"   -> Just DDumpAST
     _            -> Nothing
 
 ----------------------------------------------------------------------------------
@@ -79,13 +80,21 @@ main = do
 driver :: RLPCIO CompilerError ()
 driver = sequence_
     [ dshowFlags
+    , ddumpAST
     , ddumpEval
     ]
 
 dshowFlags :: RLPCIO CompilerError ()
 dshowFlags = whenFlag flagDDumpOpts do
     ask >>= liftIO . print
-    liftIO $ exitSuccess
+
+ddumpAST :: RLPCIO CompilerError ()
+ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
+    liftIO $ withFile f ReadMode $ \h -> do
+        s <- hGetContents h
+        case parseProg o s of
+            Right (a,_) -> hPutStrLn stderr $ show a
+            Left e -> error "todo errors lol"
 
 ddumpEval :: RLPCIO CompilerError ()
 ddumpEval = whenFlag flagDDumpEval do
@@ -104,11 +113,6 @@ ddumpEval = whenFlag flagDDumpEval do
                     Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
                     Nothing -> liftIO $ dumpEval a stderr
 
-        parseProg :: RLPCOptions
-                  -> String
-                  -> Either SrcError (Program, [SrcError])
-        parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
-
         -- choose the appropriate model based on the compiler opts
         chooseEval = do
             ev <- view rlpcEvaluator
@@ -117,3 +121,16 @@ ddumpEval = whenFlag flagDDumpEval do
                 EvaluatorTI -> v TI.hdbgProg
             where v f p h = f p h *> pure ()
 
+parseProg :: RLPCOptions
+          -> String
+          -> Either SrcError (Program, [SrcError])
+parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
+
+forFiles_ :: (Monad m)
+          => (RLPCOptions -> FilePath -> RLPCT e m a)
+          -> RLPCT e m ()
+forFiles_ k = do
+    fs <- view rlpcInputFiles
+    o <- ask
+    forM_ fs (k o)
+

doc/src/references/gm-state-transitions.rst

@@ -103,10 +103,9 @@ Core Transition Rules
       & m
       }
 
-#. If the top of the stack is in WHNF (currently this just means a number) is on
+#. If the top of the stack is in WHNF is on top of the stack, :code:`Unwind`
-   top of the stack, :code:`Unwind` considers evaluation complete. In the case
+   considers evaluation complete. In the case where the dump is **not** empty,
-   where the dump is **not** empty, the instruction queue and stack is restored
+   the instruction queue and stack is restored from the top.
-   from the top.
 
    .. math::
       \gmrule
@@ -126,6 +125,26 @@ Core Transition Rules
       & m
       }
 
+#. Consider constructors to be in WHNF
+
+   .. math::
+      \gmrule
+      { \mathtt{Unwind} : \nillist
+      & a : s
+      & \langle i', s' \rangle : d
+      & h
+      \begin{bmatrix}
+           a : \mathtt{NConstr} \; t \; v
+      \end{bmatrix}
+      & m
+      }
+      { i'
+      & a : s'
+      & d
+      & h
+      & m
+      }
+
 #. Bulding on the previous rule, in the case where the dump **is** empty, leave
    the machine in a halt state (i.e. with an empty instruction queue).
 
@@ -402,7 +421,77 @@ Core Transition Rules
       & m
       }
 
+#. Deconstruct a constructor
 
+   .. math::
+      \gmrule
+      { \mathtt{Split} \; n : i
+      & a : s
+      & d
+      & h
+      \begin{bmatrix}
+            a : \mathtt{NConstr} \; t \; [a_1,\ldots,a_n]
+      \end{bmatrix}
+      & m
+      }
+      { i
+      & a_1 : \ldots a_n : s
+      & d
+      & h
+      & m
+      }
+
+#. Allow constructors to behave as functions: look a constructor up in the
+   environment, and if push the address if found
+
+   .. math::
+      \gmrule
+      { \mathtt{PushConstr} \; p_{t,n} : i
+      & s
+      & d
+      & h
+      & m
+      \begin{bmatrix}
+            p_{t,n} : a
+      \end{bmatrix}
+      }
+      { i
+      & a : s
+      & d
+      & h
+      & m
+      }
+
+#. Expanding upon the previous rule: in the case that no such address is found,
+   update the environment
+
+   .. math::
+      \gmrule
+      { \mathtt{PushConstr} \; p_{t,n} : i
+      & s
+      & d
+      & h
+      & m
+      }
+      { i
+      & a : s
+      & d
+      & h
+      \begin{bmatrix}
+            a : g_{t,n}
+      \end{bmatrix}
+      & m
+      \begin{bmatrix}
+            p_{t,n} : a
+      \end{bmatrix}
+      \\
+      \SetCell[c=6]{c}
+      \text{where $p_{t,n}$ is a non-conflicting string rep. of
+          $\mathtt{Pack}\{t,n\}$,} \\
+      \SetCell[c=6]{c}
+      \text{and $g_{t,n} = \mathtt{NGlobal} \; n \;
+          [\mathtt{Pack} \; t \; n, \mathtt{Update} \; 0, \mathtt{Unwind}]$}
+      }
 
 ***************
 Extension Rules
@@ -436,7 +525,7 @@ Extension Rules
            n' : a
       \end{bmatrix}
       \\
-      \SetCell[c=5]{c}
+      \SetCell[c=6]{c}
       \text{where $n'$ is the base-10 string rep. of $n$}
       }
 

src/Compiler/RLPC.hs

@@ -6,7 +6,10 @@ This module implements the toolset common to the entire compiler, most notably
 errors and the family of RLPC monads.
 -}
 {-# LANGUAGE GeneralisedNewtypeDeriving, StandaloneDeriving #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell #-}
+-- only used for mtl instances
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
 module Compiler.RLPC
     ( RLPC
@@ -29,12 +32,15 @@ module Compiler.RLPC
     , whenFlag
     , flagDDumpEval
     , flagDDumpOpts
+    , flagDDumpAST
+    , def
     )
 
     where
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Monad.Reader
+import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
 import Data.Functor.Identity
 import Data.Default.Class
@@ -51,10 +57,18 @@ import Lens.Micro.TH
 newtype RLPCT e m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
     }
+    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
+    -- environment access functions
     deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
 deriving instance (MonadIO m) => MonadIO (RLPCT e m)
 
+instance MonadTrans (RLPCT e) where
+    lift = RLPCT . lift . lift
+
+instance (MonadState s m) => MonadState s (RLPCT e m) where
+    state = lift . state
+
 type RLPC e = RLPCT e Identity
 
 type RLPCIO e = RLPCT e IO
@@ -119,6 +133,7 @@ type DebugOpts = HashSet DebugFlag
 
 data DebugFlag = DDumpEval
                | DDumpOpts
+               | DDumpAST
                deriving (Show, Eq, Generic)
 
     -- deriving (Hashable)
@@ -143,3 +158,6 @@ flagDDumpEval = flagGetter DDumpEval
 flagDDumpOpts :: SimpleGetter RLPCOptions Bool
 flagDDumpOpts = flagGetter DDumpOpts
 
+flagDDumpAST :: SimpleGetter RLPCOptions Bool
+flagDDumpAST = flagGetter DDumpAST
+

src/Core/Lex.x

@@ -42,6 +42,7 @@ $octit     = 0-7
 $hexit     = [0-9 A-F a-f]
 $namechar  = [$alpha $digit \' \#]
 $symchar   = [$symbol \:]
+$nonwhite  = $printable # $white
 $nl        = [\n\r]
 $white_no_nl = $white # $nl
 
@@ -68,6 +69,7 @@ rlp :-
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
     ","                     { constTok TokenComma }
+    "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
     "let"                   { constTok TokenLet }
     "letrec"                { constTok TokenLetrec }
@@ -94,6 +96,19 @@ rlp :-
     \n                      { skip }
 }
 
+<pragma>
+{
+    "#-}"                   { constTok TokenRPragma `andBegin` 0 }
+    "{"                     { constTok TokenLBrace }
+    "}"                     { constTok TokenRBrace }
+    ";"                     { constTok TokenSemicolon }
+
+    $white                  { skip }
+    \n                      { skip }
+
+    $nonwhite+              { lexWith TokenWord }
+}
+
 {
 data Located a = Located Int Int Int a
     deriving Show
@@ -123,6 +138,9 @@ data CoreToken = TokenLet
                | TokenLBrace
                | TokenRBrace
                | TokenSemicolon
+               | TokenLPragma
+               | TokenRPragma
+               | TokenWord String
                | TokenEOF
                deriving Show
 
@@ -135,6 +153,7 @@ data SrcError = SrcError
 
 data SrcErrorType = SrcErrLexical String
                   | SrcErrParse
+                  | SrcErrUnknownPragma Name
                   deriving Show
 
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)

src/Core/Parse.y

@@ -44,6 +44,7 @@ import Data.Default.Class   (def)
       varsym          { Located _ _ _ (TokenVarSym $$) }
       conname         { Located _ _ _ (TokenConName $$) }
       consym          { Located _ _ _ (TokenConSym $$) }
+      word            { Located _ _ _ (TokenWord $$) }
       'λ'             { Located _ _ _ TokenLambda }
       '->'            { Located _ _ _ TokenArrow }
       '='             { Located _ _ _ TokenEquals }
@@ -51,6 +52,8 @@ import Data.Default.Class   (def)
       ')'             { Located _ _ _ TokenRParen }
       '{'             { Located _ _ _ TokenLBrace }
       '}'             { Located _ _ _ TokenRBrace }
+      '{-#'           { Located _ _ _ TokenLPragma }
+      '#-}'           { Located _ _ _ TokenRPragma }
       ';'             { Located _ _ _ TokenSemicolon }
       eof             { Located _ _ _ TokenEOF }
 
@@ -122,8 +125,16 @@ Expr1           :: { Expr }
 Expr1           : litint                        { IntE $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
+                | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
+ExprPragma      :: { Expr }
+ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
+
+Words           :: { [String] }
+Words           : word Words                    { $1 : $2 }
+                | word                          { [$1] }
+
 PackCon         :: { Expr }
 PackCon         : pack '{' litint ',' litint '}' { Con $3 $5 }
 
@@ -148,6 +159,7 @@ Con             : '(' consym ')'                    { $2 }
                 | conname                           { $1 }
 
 {
+
 parseError :: [Located CoreToken] -> RLPC SrcError a
 parseError (Located y x l _ : _) = addFatal err
     where err = SrcError
@@ -165,5 +177,17 @@ parseTmp = do
     where
         parse = evalRLPC def . (lexCore >=> parseCore)
 
+exprPragma :: [String] -> RLPC SrcError Expr
+exprPragma ("AST" : e) = astPragma e
+exprPragma _           = addFatal err
+    where err = SrcError
+            { _errSpan       = (0,0,0) -- TODO: span
+            , _errSeverity   = Warning
+            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
+            }
+
+astPragma :: [String] -> RLPC SrcError Expr
+astPragma = pure . read . unwords
+
 }
 

src/Core/Syntax.hs

@@ -38,7 +38,7 @@ data Expr = Var Name
           | Lam [Name] Expr
           | App Expr Expr
           | IntE Int
-          deriving (Show, Lift, Eq)
+          deriving (Show, Read, Lift, Eq)
 
 infixl 2 :$
 pattern (:$) :: Expr -> Expr -> Expr
@@ -47,7 +47,7 @@ pattern f :$ x = App f x
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
 data Binding = Binding Name Expr
-    deriving (Show, Lift, Eq)
+    deriving (Show, Read, Lift, Eq)
 
 infixl 1 :=
 pattern (:=) :: Name -> Expr -> Binding
@@ -55,10 +55,10 @@ pattern k := v = Binding k v
 
 data Rec = Rec
          | NonRec
-         deriving (Show, Eq, Lift)
+         deriving (Show, Read, Eq, Lift)
 
 data Alter = Alter Tag [Name] Expr
-    deriving (Show, Lift, Eq)
+    deriving (Show, Read, Lift, Eq)
 
 type Name = String
 type Tag = Int

src/GM.hs

@@ -163,8 +163,18 @@ step st = case head (st ^. gmCode) of
     Mul            -> mulI           
     Div            -> divI           
     Split      n   -> splitI        n
+    Pack       t n -> packI       t n
     where
 
+        packI :: Tag -> Int -> GmState
+        packI t n = st
+                  & advanceCode
+                  & gmStack %~ (a:)
+                  & gmHeap  .~ h'
+            where
+                (as,s) = splitAt n (st ^. gmStack)
+                (h',a) = alloc (st ^. gmHeap) $ NConstr t as
+
         pushGlobalI :: Name -> GmState
         pushGlobalI k = st
                       & advanceCode
@@ -178,7 +188,23 @@ step st = case head (st ^. gmCode) of
                   & fromMaybe (error $ "undefined var: " <> show k)
 
         pushConstrI :: Tag -> Int -> GmState
-        pushConstrI = undefined
+        pushConstrI t n = st
+                        & advanceCode
+                        & gmStack %~ (a:)
+                        & gmEnv   .~ m'
+                        & gmHeap  .~ h'
+            where
+                s = st ^. gmStack
+                m = st ^. gmEnv
+                h = st ^. gmHeap
+                (a,m',h') = case lookupC t n m of
+                    -- address found in env; no need to update env or heap
+                    Just aa -> (aa,m,h)
+                    Nothing -> (aa,mm,hh)
+                        where
+                            (hh,aa) = alloc h (NGlobal n c)
+                            c = [Pack t n, Update 0, Unwind]
+                            mm = (ConstrKey t n, aa) : m
 
         -- Extension Rules 1,2 (sharing)
         pushIntI :: Int -> GmState
@@ -339,6 +365,19 @@ step st = case head (st ^. gmCode) of
                         -- leave the stack as is
                         []          -> ([], s, [])
 
+            NConstr t n -> st
+                         & gmCode  .~ i'
+                         & gmStack .~ s'
+                         & gmDump  .~ d'
+                where
+                    (i',s',d') = case st ^. gmDump of
+                        -- if the dump is non-empty, restore the instruction
+                        -- queue and stack, and pop the dump
+                        ((ii,ss):d) -> (ii,a:ss,d)
+                        -- if the dump is empty, clear the instruction queue and
+                        -- leave the stack as is
+                        []          -> ([], s, [])
+
             NAp f _     -> st
                          -- leave the Unwind instr; continue unwinding
                          & gmStack %~ (f:)
@@ -537,8 +576,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 compileBinder (_ := v, a) = compileC g' v <> [Update a]
 
         -- kinda evil; better system eventually
-        compileC g (Con t n) = [PushGlobal p]
+        compileC g (Con t n) = [PushConstr t n]
-            where p = idPack t n
 
         compileC _ _ = error "yet to be implemented!"
 
@@ -607,8 +645,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-        idPack :: Tag -> Int -> String
+idPack :: Tag -> Int -> String
-        idPack t n = printf "Pack{%d,%d}" t n
+idPack t n = printf "Pack{%d,%d}" t n
 
 ----------------------------------------------------------------------------------
 
@@ -729,11 +767,14 @@ showNodeAtP p st a = case hLookup a h of
             g = st ^. gmEnv
             name = case lookup a (swap <$> g) of
                 Just (NameKey n)     -> n
+                Just (ConstrKey t n) -> idPack t n
                 _                     -> errTxtInvalidAddress
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
         where pprec = maybeParens (p > 0)
     Just (NInd a')       -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
         where pprec = maybeParens (p > 0)
+    Just (NConstr t as)  -> pprec $ "NConstr" <+> int t <+> text (show as)
+        where pprec = maybeParens (p > 0)
     Just NUninitialised  -> "<uninitialised>"
     Nothing              -> errTxtInvalidAddress
     where h = st ^. gmHeap