msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

shitty temp frontend

Browse Source
This commit is contained in:
crumbtoo
2023-11-22 21:53:36 -07:00
parent 8195895233
commit ac6c0b7457
10 changed files with 198 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

72
app/Main.hs
View File

@@ -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)

54
docs/src/commentary/stg.rst
View File

@@ -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
}

11
rlp.cabal
View File

@@ -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
build-depends: base ^>=4.18.0.0
, rlp
, optparse-applicative
, microlens
, microlens-mtl
, mtl
hs-source-dirs: app
default-language: GHC2021

37
src/Compiler/RLPC.hs
View File

@@ -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 []

4
src/Control/Monad/Errorful.hs
View File

@@ -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

7
src/Core.hs
View File

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

4
src/Core/Examples.hs
View File

@@ -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"
]

3
src/Core/Parse.y
View File

@@ -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)
}

7
src/Core/TH.hs
View File

@@ -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)

17
src/TIM.hs
View File

@@ -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))