shitty temp frontend

app/Main.hs

@@ -1,5 +1,75 @@
+{-# LANGUAGE BlockArguments #-}
 module Main where
 ----------------------------------------------------------------------------------
+import Compiler.RLPC
+import Options.Applicative      hiding (ParseError)
+import Control.Monad
+import Control.Monad.Reader
+import System.IO
+import Core
+import TIM
+import Lens.Micro
+import Lens.Micro.Mtl
+----------------------------------------------------------------------------------
+
+optParser :: ParserInfo RLPCOptions
+optParser = info (helper <*> options)
+    (  fullDesc
+    <> progDesc "Compile rl' programs"
+    <> header "rlpc - The Inglorious rl' Compiler"
+    )
+
+options :: Parser RLPCOptions
+options = RLPCOptions
+    <$> optional # strOption
+        (  long "log"
+        <> short 'l'
+        <> metavar "FILE"
+        <> help "output dumps to FILE. stderr is used by default"
+        )
+    -- temp. i want gcc/ghc style options
+    <*> switch 
+        (  long "dump-evals"
+        <> short 'd'
+        <> help "dump evaluation logs"
+        )
+    <*> some (argument str (metavar "FILES..."))
+    where
+        infixr 9 #
+        f # x = f x
 
 main :: IO ()
-main = putStrLn "god i love you haskell i love you ghc i love you functionalprogramming researchers"
+main = do
+    opts <- execParser optParser
+    evalRLPCIO opts driver
+    pure ()
+
+driver :: RLPCIO () ()
+driver = sequence_
+    [ dumpEval
+    ]
+
+whenView :: (MonadReader s m) => Getting Bool s Bool -> m () -> m ()
+whenView l m = view l >>= \a -> when a m
+
+dumpEval :: RLPCIO () ()
+dumpEval = whenView rlpcDumpEval do
+    fs <- view rlpcInputFiles
+    forM_ fs $ \f -> liftIO (readFile f) >>= doProg 
+
+    where
+        doProg :: String -> RLPCIO () ()
+        doProg s = ask >>= \o -> case parseProg o s of
+            -- TODO: error handling
+            Left e -> error $ show e
+            Right (a,_) -> do
+                log <- view rlpcLogFile
+                case log of
+                    Just f  -> void . liftIO $ withFile f WriteMode $ hdbgProg a
+                    Nothing -> void . liftIO $ hdbgProg a stderr
+
+        parseProg :: RLPCOptions
+                  -> String
+                  -> Either (SrcError ParseError) (Program, [SrcError ParseError])
+        parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
+

docs/src/commentary/stg.rst

@@ -158,7 +158,7 @@ evaluated as True (:code:`NData 1 []`).
    & h
    \begin{bmatrix}
         f : \mathtt{NPrim} \; \mathtt{IfP} \\
-        c : \mathtt{NPrim} \; (\mathtt{NData} \; 1 \; []) \\
+        c : \mathtt{NPrim} \; (\mathtt{NData} \; 1 \; \nillist) \\
         a_1 : \mathtt{NAp} \; f \; c \\
         a_2 : \mathtt{NAp} \; a_1 \; x \\
         a_3 : \mathtt{NAp} \; a_2 \; y
@@ -181,7 +181,7 @@ evaluated as False (:code:`NData 0 []`).
    & h
    \begin{bmatrix}
         f : \mathtt{NPrim} \; \mathtt{IfP} \\
-        c : \mathtt{NPrim} \; (\mathtt{NData} \; 0 \; []) \\
+        c : \mathtt{NPrim} \; (\mathtt{NData} \; 0 \; \nillist) \\
         a_1 : \mathtt{NAp} \; f \; c \\
         a_2 : \mathtt{NAp} \; a_1 \; x \\
         a_3 : \mathtt{NAp} \; a_2 \; y
@@ -237,3 +237,53 @@ Construct :code:`NData` out of a constructor and its arguments
    \end{bmatrix}
    & g
    }
+
+Pairs
+-----
+
+Evaluate the first argument if necessary
+
+.. math::
+   \transrule
+   { c : a_1 : a_2 : \nillist
+   & d
+   & h
+   \begin{bmatrix}
+        c : \mathtt{NPrim} \; \mathtt{CasePairP} \\
+        p : \mathtt{NAp} \; \_ \: \_ \\
+        a_1 : \mathtt{NAp} \; c \; p \\
+        a_2 : \mathtt{NAp} \; a_2 \; f
+   \end{bmatrix}
+   & g
+   }
+   { p : \nillist
+   & (c : a_1 : a_2 : \nillist) : d
+   & h
+   & g
+   }
+
+Perform the reduction if the first argument is in normal form
+
+.. math::
+   \transrule
+   { c : a_1 : a_2 : s
+   & d
+   & h
+   \begin{bmatrix}
+        c : \mathtt{NPrim} \; \mathtt{CasePairP} \\
+        p : \mathtt{NData} \; 0 \; [x,y] \\
+        a_1 : \mathtt{NAp} \; c \; p \\
+        a_2 : \mathtt{NAp} \; a_1 \; f
+   \end{bmatrix}
+   & g
+   }
+   { a_2 : s
+   & d
+   & h
+   \begin{bmatrix}
+        a_1 : \mathtt{NAp} \; f \; x \\
+        a_2 : \mathtt{NAp} \; a_1 \; y
+   \end{bmatrix}
+   & g
+   }
+

rlp.cabal

@@ -20,6 +20,8 @@ library
     import:           warnings
     exposed-modules:  Core
                     , TIM
+                    , Compiler.RLPC
+
     other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Syntax
@@ -27,7 +29,6 @@ library
                     , Core.TH
                     , Core.Examples
                     , Core.Lex
-                    , Compiler.RLPC
                     , Control.Monad.Errorful
 
     build-tool-depends: happy:happy, alex:alex
@@ -41,6 +42,7 @@ library
                     , template-haskell
                     -- required for happy
                     , array
+                    , data-default-class
     hs-source-dirs:   src
     default-language: GHC2021
 
@@ -49,9 +51,12 @@ executable rlpc
     main-is:          Main.hs
     -- other-modules:
     -- other-extensions:
-    build-depends:
+    build-depends: base ^>=4.18.0.0
-          base ^>=4.18.0.0
+                 , rlp
-        , rlp
+                 , optparse-applicative
+                 , microlens
+                 , microlens-mtl
+                 , mtl
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/RLPC.hs

@@ -1,21 +1,28 @@
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving, StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Compiler.RLPC
     ( RLPC(..)
+    , RLPCIO
     , RLPCOptions(RLPCOptions)
     , addFatal
     , addWound
     , Severity(..)
     , SrcError(..)
     , evalRLPCT
+    , evalRLPCIO
     , evalRLPC
+    , rlpcLogFile   
+    , rlpcDumpEval  
+    , rlpcInputFiles
     )
+
     where
 ----------------------------------------------------------------------------------
 import Control.Arrow            ((>>>))
 import Control.Monad.Reader
 import Control.Monad.Errorful
 import Data.Functor.Identity
+import Data.Default.Class
 import Data.Coerce
 import Lens.Micro
 import Lens.Micro.TH
@@ -27,8 +34,12 @@ newtype RLPCT e m a = RLPC {
     }
     deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
+deriving instance (MonadIO m) => MonadIO (RLPCT e m)
+
 type RLPC e = RLPCT e Identity
 
+type RLPCIO e = RLPCT e IO
+
 evalRLPCT :: RLPCOptions
           -> RLPCT e m a
           -> m (Either (SrcError e) (a, [SrcError e]))
@@ -39,7 +50,29 @@ evalRLPC :: RLPCOptions
          -> Either (SrcError e) (a, [SrcError e])
 evalRLPC o m = coerce $ evalRLPCT o m
 
+evalRLPCIO :: RLPCOptions
+           -> RLPCIO e a
+           -> IO (a, [SrcError e])
+evalRLPCIO o m = do
+    m' <- evalRLPCT o m
+    case m' of
+        Left e -> error "need to impl io errors llol" -- TODO
+        Right a -> pure a
+    
+
 data RLPCOptions = RLPCOptions
+    { _rlpcLogFile    :: Maybe FilePath
+    , _rlpcDumpEval   :: Bool
+    , _rlpcInputFiles :: [FilePath]
+    }
+    deriving Show
+
+instance Default RLPCOptions where
+    def = RLPCOptions
+        { _rlpcLogFile = Nothing
+        , _rlpcDumpEval = False
+        , _rlpcInputFiles = []
+        }
 
 data SrcError e = SrcError
     { _errSpan       :: (Int, Int, Int)
@@ -60,7 +93,7 @@ type ErrorDoc = String
 class Diagnostic e where
     errorDoc :: e -> ErrorDoc
 
--- makeLenses ''RLPCOptions
+makeLenses ''RLPCOptions
 makeLenses ''SrcError
 
 pure []

src/Control/Monad/Errorful.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TupleSections, PatternSynonyms #-}
 module Control.Monad.Errorful
@@ -40,6 +41,9 @@ instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
 instance MonadTrans (ErrorfulT e) where
     lift m = ErrorfulT (Right . (,[]) <$> m)
 
+instance (MonadIO m) => MonadIO (ErrorfulT e m) where
+    liftIO = lift . liftIO
+
 instance (Functor m) => Functor (ErrorfulT e m) where
     fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
 

src/Core.hs

@@ -1,7 +1,14 @@
 module Core
     ( module Core.Syntax
+    , parseCore
+    , parseCoreProg
+    , parseCoreExpr
+    , lexCore
+    , ParseError
     )
     where
 ----------------------------------------------------------------------------------
 import Core.Syntax
+import Core.Parse
+import Core.Lex
 

src/Core/Examples.hs

@@ -88,11 +88,11 @@ corePrelude = Module (Just ("Prelude", [])) $ Program
     , ScDef "k" ["x", "y"] $ "x"
     , ScDef "k1" ["x", "y"] $ "y"
     , ScDef "succ" ["f", "g", "x"] $ "f" :$ "x" :$ ("g" :$ "x")
-    , ScDef "compose" ["f", "g", "x"] "f" :$ ("g" :$ "x")
+    , ScDef "compose" ["f", "g", "x"] $ "f" :$ ("g" :$ "x")
     , ScDef "twice" ["f", "x"] $ "f" :$ ("f" :$ "x")
     , ScDef "False" [] $ Con 0 0
     , ScDef "True" [] $ Con 1 0
-    , ScDef "MkPair" [] $ Con 1 2
+    , ScDef "MkPair" [] $ Con 0 2
     , ScDef "fst" ["p"] $ "casePair#" :$ "p" :$ "k"
     , ScDef "snd" ["p"] $ "casePair#" :$ "p" :$ "k1"
     ]

src/Core/Parse.y

@@ -16,6 +16,7 @@ import Data.Foldable        (foldl')
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Data.Default.Class   (def)
 }
 
 %name parseCore Module
@@ -152,7 +153,7 @@ parseTmp = do
         Left e -> error (show e)
         Right (ts,_) -> pure ts
     where
-        parse = evalRLPC RLPCOptions . (lexCore >=> parseCore)
+        parse = evalRLPC def . (lexCore >=> parseCore)
 
 }
 

src/Core/TH.hs

@@ -10,6 +10,7 @@ import Language.Haskell.TH.Syntax hiding (Module)
 import Language.Haskell.TH.Quote
 import Control.Monad                ((>=>))
 import Compiler.RLPC
+import Data.Default.Class           (def)
 import Core.Parse
 import Core.Lex
 ----------------------------------------------------------------------------------
@@ -43,19 +44,19 @@ qCore s = case parse s of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where
-        parse = evalRLPC RLPCOptions . (lexCore >=> parseCore)
+        parse = evalRLPC def . (lexCore >=> parseCore)
 
 qCoreExpr :: String -> Q Exp
 qCoreExpr s = case parseExpr s of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where
-        parseExpr = evalRLPC RLPCOptions . (lexCore >=> parseCoreExpr)
+        parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
 
 qCoreProg :: String -> Q Exp
 qCoreProg s = case parseProg s of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where
-        parseProg = evalRLPC RLPCOptions . (lexCore >=> parseCoreProg)
+        parseProg = evalRLPC def . (lexCore >=> parseCoreProg)
 

src/TIM.hs

@@ -4,12 +4,9 @@
 {-# LANGUAGE TemplateHaskell #-}
 module TIM
     ( module Core.Examples
+    , hdbgProg
     ) where
 ----------------------------------------------------------------------------------
-import Data.Map                 (Map, (!?), (!))
-import Data.Map qualified as M
-import Data.Set                 (Set)
-import Data.Set qualified as S
 import Data.Maybe               (fromJust, fromMaybe)
 import Data.List                (mapAccumL, intersperse)
 import Control.Monad            (guard)
@@ -287,6 +284,16 @@ step st =
                     NData 0 [] -> False
                     NData 1 [] -> True
 
+        primStep _ CasePairP (TiState s d h g sts) =
+            case needsEval pn of
+                True  -> TiState s' d' h g sts
+                    where s' = undefined; d' = undefined
+                False -> TiState s' d h' g sts
+                    where s' = undefined; h' = undefined
+            where
+                [p,f] = getArgs h s
+                pn = undefined
+
         primStep n (ConP t a) (TiState s d h g sts) =
             TiState s' d h' g sts
             where
@@ -465,7 +472,7 @@ instance Pretty TiState where
 
             pnode (NPrim n _) _ = IStr n
 
-            pnode (NData t cs) p = "NData{" <> IStr (show t) <> "}" <> m
+            pnode (NData t cs) p = "NData{" <> IStr (show t) <> "} " <> m
                 where
                     m = cs
                       & fmap (\a -> pnode (hLookupUnsafe a h) (succ p))