rc (#13)
* update readme * Literal -> Lit, LitE -> Lit * commentary * infer * hindley milner inference :D * comments and better type errors * type IsString + test unification error * infer nonrec let binds infer nonrec let binds * small * LitE -> Lit * LitE -> Lit * TyInt -> TyCon "Int#" * parse type sigs; program type sigs * parse types * parse programs (with types :D) * parse programs (with type sigs :D) * Name = Text Name = Text * RlpcError * i'm on an airplane rn, my eyelids grow heavy, and i forgot my medication. should this be my final commit (of the week): gootbye * kinda sorta typechecking * back and medicated! * errorful (it's not good) * type-checked quasiquoters * fix hm tests * Compiler.JustRun * lex \ instead of \\ * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * add version bounds * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * its fine * threaded lexer * decent starting point * man this sucks * aagh * okay layouts kinda * kitten i'll be honest mommy's about to kill herself * see previous commit and scale back the part where i'm joking * version bounds * we're so back * fixy * cool * FIX REAL * oh my god * works * now we're fucking GETTING SOMEWHERE * i really need to learn git proper * infix exprs * remove debug flags * renamerlp * rename rlp * compiles (kill me) man * RlpcError -> IsRlpcError * when the "Test suite rlp-test: PASS" hits i'm like atlas and the world is writing two lines of code * errorful parser * errorful parser small * msgenvelope * errors! * allow uppercase sc names in preperation for Rlp2Core * letrec * infer letrec expressions * minor docs * checklist * minor docs * stable enough for a demo hey? * small fixups * new tag syntax; preparing for Core patterns new tag syntax; preparing for data names * temporary pragma system * resolve named data in case exprs * named constr tests * nearing release :3 * minor changes putting this on hold; implementing TTG first * some * oh my god guys!!! `Located` is a lax semimonoidal endofunctor on the category Hask!!!  * it's also a comonad. lol. * idk * show * abandon ship * at long last more no more undefineds * i should've made a lisp man this sucks * let layout * ttg boilerplate * fixup! ttg boilerplate * fixup! ttg boilerplate * organisation and cleaning organisation and tidying * error messages * driver progress * formatting * *R functions * -ddump-ast * debug tags * -ddump-eval * core driver * XRec fix * rlp2core base * ccoool * something * rlp TH * sc * expandableAlt * expandableAlt * fix layout_let * parse case exprs * case unrolling * rose * her light cuts deep time and time again ('her' of course referring to the field of computer science) * tidying * NameSupply effect * tidy * fix incomplete byTag * desugar * WIP associate postproc corecursive * sigh i'm gonna have to nuke the ast again in a month * remove old files * remove old files * fix top-level layout * define datatags * diagram * diagram * Update README.md * ppr debug flags ddump-parsed * ppr typesigs * ppr datatags * remove unnecessary comment * tidying * .hs -> .cr update examples * fix evil parser bug (it was a fucking typo) * fix evil lexer bug (it was actually quite subtle unlike prev.) * examples * examples * letrec + typechecking core * Update README.md * Rlp2Core: simple let binds * Rlp2Core: pattern let binds * small core fixes * update examples * formatting * typed coreExpr quoter * typechecking things * lt * decent state! * constants for bool tags * print# gm primitive * bind VarP after pats * fix: tag nested data names * gte gm prim * more nightmare GM fixes * QuickSort example works i'm gonig to cry * remove debug code * remove debug tracers * ready? * update readme * remove bad, incorrct, outdated docs --------- Co-authored-by: crumbtoo <crumb@disroot.org>
This commit was merged in pull request #13.
This commit is contained in:
crumb
137
app/Main.hs
137
app/Main.hs
@@ -1,18 +1,28 @@
|
||||
{-# LANGUAGE BlockArguments, LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
----------------------------------------------------------------------------------
|
||||
import Compiler.RLPC
|
||||
import Compiler.RlpcError
|
||||
import Control.Exception
|
||||
import Options.Applicative hiding (ParseError)
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.HashSet qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO qualified as TIO
|
||||
import Data.List
|
||||
import Data.Maybe (listToMaybe)
|
||||
import System.IO
|
||||
import System.Exit (exitSuccess)
|
||||
import Core
|
||||
import TI
|
||||
import GM
|
||||
import Lens.Micro.Mtl
|
||||
import Lens.Micro.Platform
|
||||
|
||||
import CoreDriver qualified
|
||||
import RlpDriver qualified
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
optParser :: ParserInfo RLPCOptions
|
||||
@@ -34,9 +44,15 @@ options = RLPCOptions
|
||||
{- -d -}
|
||||
<*> fmap S.fromList # many # option debugFlagReader
|
||||
( short 'd'
|
||||
<> help "dump evaluation logs"
|
||||
<> help "pass debug flags"
|
||||
<> metavar "DEBUG FLAG"
|
||||
)
|
||||
{- -f -}
|
||||
<*> fmap S.fromList # many # option compilerFlagReader
|
||||
( short 'f'
|
||||
<> help "pass compilation flags"
|
||||
<> metavar "COMPILATION FLAG"
|
||||
)
|
||||
{- --evaluator, -e -}
|
||||
<*> option evaluatorReader
|
||||
( long "evaluator"
|
||||
@@ -52,96 +68,73 @@ options = RLPCOptions
|
||||
\triggering the garbage collector"
|
||||
<> value 50
|
||||
)
|
||||
<*> optional # option languageReader
|
||||
( long "language"
|
||||
<> short 'x'
|
||||
<> metavar "rlp|core"
|
||||
<> help "the language to be compiled -- see README"
|
||||
)
|
||||
<*> some (argument str $ metavar "FILES...")
|
||||
where
|
||||
infixr 9 #
|
||||
f # x = f x
|
||||
|
||||
languageReader :: ReadM Language
|
||||
languageReader = maybeReader $ \case
|
||||
"rlp" -> Just LanguageRlp
|
||||
"core" -> Just LanguageCore
|
||||
"rl" -> Just LanguageRlp
|
||||
"cr" -> Just LanguageCore
|
||||
_ -> Nothing
|
||||
|
||||
debugFlagReader :: ReadM DebugFlag
|
||||
debugFlagReader = str
|
||||
|
||||
compilerFlagReader :: ReadM CompilerFlag
|
||||
compilerFlagReader = str
|
||||
|
||||
evaluatorReader :: ReadM Evaluator
|
||||
evaluatorReader = maybeReader $ \case
|
||||
"gm" -> Just EvaluatorGM
|
||||
"tim" -> Just EvaluatorTI
|
||||
"ti" -> Just EvaluatorTI
|
||||
_ -> Nothing
|
||||
|
||||
mmany :: (Alternative f, Monoid m) => f m -> f m
|
||||
mmany v = liftA2 (<>) v (mmany v)
|
||||
|
||||
debugFlagReader :: ReadM DebugFlag
|
||||
debugFlagReader = maybeReader $ \case
|
||||
"dump-eval" -> Just DDumpEval
|
||||
"dump-opts" -> Just DDumpOpts
|
||||
"dump-ast" -> Just DDumpAST
|
||||
_ -> Nothing
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- temp
|
||||
data CompilerError = CompilerError String
|
||||
deriving Show
|
||||
|
||||
instance Exception CompilerError
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- execParser optParser
|
||||
(_, es) <- evalRLPCIO opts driver
|
||||
forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
|
||||
pure ()
|
||||
void $ evalRLPCIO opts dispatch
|
||||
|
||||
driver :: RLPCIO CompilerError ()
|
||||
driver = sequence_
|
||||
[ dshowFlags
|
||||
, ddumpAST
|
||||
, ddumpEval
|
||||
]
|
||||
dispatch :: RLPCIO ()
|
||||
dispatch = getLang >>= \case
|
||||
Just LanguageCore -> CoreDriver.driver
|
||||
Just LanguageRlp -> RlpDriver.driver
|
||||
Nothing -> addFatal err
|
||||
where
|
||||
-- TODO: why didn't i make the srcspan optional LOL
|
||||
err = errorMsg (SrcSpan 0 0 0 0) $ Text
|
||||
[ "Could not determine source language from filetype."
|
||||
, "Possible Solutions:\n\
|
||||
\ Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
|
||||
\ Specify a language with `rlpc -x core' or `rlpc -x rlp'"
|
||||
]
|
||||
where
|
||||
getLang = liftA2 (<|>)
|
||||
(view rlpcLanguage)
|
||||
-- TODO: we only check the first file lol
|
||||
((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
|
||||
|
||||
dshowFlags :: RLPCIO CompilerError ()
|
||||
dshowFlags = whenFlag flagDDumpOpts do
|
||||
ask >>= liftIO . print
|
||||
|
||||
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"
|
||||
driver :: RLPCIO ()
|
||||
driver = undefined
|
||||
|
||||
ddumpEval :: RLPCIO CompilerError ()
|
||||
ddumpEval = whenFlag flagDDumpEval do
|
||||
fs <- view rlpcInputFiles
|
||||
forM_ fs $ \f -> liftIO (readFile f) >>= doProg
|
||||
|
||||
where
|
||||
doProg :: String -> RLPCIO CompilerError ()
|
||||
doProg s = ask >>= \o -> case parseProg o s of
|
||||
-- TODO: error handling
|
||||
Left e -> addFatal . CompilerError $ show e
|
||||
Right (a,_) -> do
|
||||
log <- view rlpcLogFile
|
||||
dumpEval <- chooseEval
|
||||
case log of
|
||||
Just f -> liftIO $ withFile f WriteMode $ dumpEval a
|
||||
Nothing -> liftIO $ dumpEval a stderr
|
||||
|
||||
-- choose the appropriate model based on the compiler opts
|
||||
chooseEval = do
|
||||
ev <- view rlpcEvaluator
|
||||
pure $ case ev of
|
||||
EvaluatorGM -> v GM.hdbgProg
|
||||
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)
|
||||
inferLanguage :: FilePath -> Maybe Language
|
||||
inferLanguage fp
|
||||
| ".rl" `isSuffixOf` fp = Just LanguageRlp
|
||||
| ".cr" `isSuffixOf` fp = Just LanguageCore
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
Reference in New Issue
Block a user