diff --git a/app/Main.hs b/app/Main.hs index 10ac1f4..014e204 100644 --- a/app/Main.hs +++ b/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) + diff --git a/docs/src/commentary/stg.rst b/docs/src/commentary/stg.rst index 6471004..622ae26 100644 --- a/docs/src/commentary/stg.rst +++ b/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 + } + diff --git a/rlp.cabal b/rlp.cabal index 38988af..0637aca 100644 --- a/rlp.cabal +++ b/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: - base ^>=4.18.0.0 - , rlp + build-depends: base ^>=4.18.0.0 + , rlp + , optparse-applicative + , microlens + , microlens-mtl + , mtl hs-source-dirs: app default-language: GHC2021 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index c56333e..5f0e622 100644 --- a/src/Compiler/RLPC.hs +++ b/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 [] diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 8e309b6..4aa2d43 100644 --- a/src/Control/Monad/Errorful.hs +++ b/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 diff --git a/src/Core.hs b/src/Core.hs index 5b62cb8..aaab099 100644 --- a/src/Core.hs +++ b/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 diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 4a72ad6..529e164 100644 --- a/src/Core/Examples.hs +++ b/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" ] diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 259faf3..bacd40e 100644 --- a/src/Core/Parse.y +++ b/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) } diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 3f70bd5..ac283b1 100644 --- a/src/Core/TH.hs +++ b/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) diff --git a/src/TIM.hs b/src/TIM.hs index e69b560..2c7aa40 100644 --- a/src/TIM.hs +++ b/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))