From 36a17d092bbde1dedb071479c70227fff8ad987f Mon Sep 17 00:00:00 2001 From: crumb <95563276+crumbtoo@users.noreply.github.com> Date: Tue, 13 Feb 2024 13:22:23 -0700 Subject: [PATCH] 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!!! ![abstractionjak](https://media.discordapp.net/attachments/1101767463579951154/1200248978642567168/3877820-20SoyBooru.png?ex=65c57df8&is=65b308f8&hm=67da3acb61861cab6156df014b397d78fb8815fa163f2e992474d545beb668ba&=&format=webp&quality=lossless&width=880&height=868) * 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 --- .ghci | 24 ++ CHANGELOG.md | 19 + Makefile_happysrcs | 25 ++ README.md | 128 +++++-- app/CoreDriver.hs | 24 ++ app/Main.hs | 137 ++++--- app/RlpDriver.hs | 19 + doc/src/commentary/gm.rst | 73 ++-- doc/src/commentary/layout-lexing.rst | 204 ++-------- doc/src/commentary/ti.rst | 6 - doc/src/commentary/type-inference.rst | 5 + doc/src/conf.py | 3 +- doc/src/references/rlp-grammar.rst | 67 ++++ doc/src/references/rlp-inference-rules.rst | 17 + examples/Core/constDivZero.cr | 3 + examples/{factorial.hs => Core/factorial.cr} | 4 +- examples/Core/sumList.cr | 12 + examples/constDivZero.hs | 3 - examples/rlp/QuickSort.rl | 31 ++ examples/rlp/SumList.rl | 11 + examples/sumList.hs | 9 - programming-language-checklist | 105 ++++++ rlp.cabal | 93 +++-- rlpc.drawio | 253 +++++++++++++ rlpc.drawio.svg | 4 + src/Compiler/JustRun.hs | 59 +++ src/Compiler/RLPC.hs | 274 +++++++++----- src/Compiler/RlpcError.hs | 77 ++++ src/Compiler/Types.hs | 99 +++++ src/Control/Monad/Errorful.hs | 76 ++-- src/Control/Monad/Utils.hs | 37 ++ src/Core/Examples.hs | 116 +++--- src/Core/HindleyMilner.hs | 280 ++++++++++++++ src/Core/Lex.x | 65 ++-- src/Core/Lex.x.old | 315 ---------------- src/Core/Parse.y | 203 ++++++---- src/Core/Parse.y.old | 159 -------- src/Core/Syntax.hs | 199 ++++++++-- src/Core/TH.hs | 67 ++-- src/Core/Utils.hs | 35 +- src/Core2Core.hs | 76 +++- src/Data/Heap.hs | 18 +- src/Data/Pretty.hs | 99 +++-- src/GM.hs | 164 ++++++-- src/RLP/Syntax.hs | 59 --- src/Rlp/Lex.x | 378 +++++++++++++++++++ src/Rlp/Parse.y | 312 +++++++++++++++ src/Rlp/Parse/Associate.hs | 37 ++ src/Rlp/Parse/Types.hs | 294 +++++++++++++++ src/Rlp/Syntax.hs | 363 ++++++++++++++++++ src/Rlp/TH.hs | 36 ++ src/Rlp2Core.hs | 238 ++++++++++++ tst/Arith.hs | 6 +- tst/Core/HindleyMilnerSpec.hs | 62 +++ tst/GMSpec.hs | 15 +- 55 files changed, 4117 insertions(+), 1380 deletions(-) create mode 100644 .ghci create mode 100644 CHANGELOG.md create mode 100644 Makefile_happysrcs create mode 100644 app/CoreDriver.hs create mode 100644 app/RlpDriver.hs delete mode 100644 doc/src/commentary/ti.rst create mode 100644 doc/src/commentary/type-inference.rst create mode 100644 doc/src/references/rlp-grammar.rst create mode 100644 doc/src/references/rlp-inference-rules.rst create mode 100644 examples/Core/constDivZero.cr rename examples/{factorial.hs => Core/factorial.cr} (50%) create mode 100644 examples/Core/sumList.cr delete mode 100644 examples/constDivZero.hs create mode 100644 examples/rlp/QuickSort.rl create mode 100644 examples/rlp/SumList.rl delete mode 100644 examples/sumList.hs create mode 100644 programming-language-checklist create mode 100644 rlpc.drawio create mode 100644 rlpc.drawio.svg create mode 100644 src/Compiler/JustRun.hs create mode 100644 src/Compiler/RlpcError.hs create mode 100644 src/Compiler/Types.hs create mode 100644 src/Control/Monad/Utils.hs create mode 100644 src/Core/HindleyMilner.hs delete mode 100644 src/Core/Lex.x.old delete mode 100644 src/Core/Parse.y.old delete mode 100644 src/RLP/Syntax.hs create mode 100644 src/Rlp/Lex.x create mode 100644 src/Rlp/Parse.y create mode 100644 src/Rlp/Parse/Associate.hs create mode 100644 src/Rlp/Parse/Types.hs create mode 100644 src/Rlp/Syntax.hs create mode 100644 src/Rlp/TH.hs create mode 100644 src/Rlp2Core.hs create mode 100644 tst/Core/HindleyMilnerSpec.hs diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..75be915 --- /dev/null +++ b/.ghci @@ -0,0 +1,24 @@ +-- repl extensions +:set -XOverloadedStrings + +-------------------------------------------------------------------------------- + +-- happy/alex: override :r to rebuild parsers +:set -package process + +:{ +import System.Exit qualified +import System.Process qualified + +_reload_and_make _ = do + p <- System.Process.spawnCommand "make -f Makefile_happysrcs" + r <- System.Process.waitForProcess p + case r of + System.Exit.ExitSuccess -> pure ":reload" + _ -> pure "" +:} + +:def! r _reload_and_make + +-------------------------------------------------------------------------------- + diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..88e5ac0 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,19 @@ +# unreleased + +* New tag syntax: + ```hs + case x of + { 1 -> something + ; 2 -> another + } + ``` + is now written as + ```hs + case x of + { <1> -> something + ; <2> -> another + } + ``` + +# Release 1.0.0 + diff --git a/Makefile_happysrcs b/Makefile_happysrcs new file mode 100644 index 0000000..f4041ee --- /dev/null +++ b/Makefile_happysrcs @@ -0,0 +1,25 @@ +HAPPY = happy +HAPPY_OPTS = -a -g -c -i/tmp/t.info +ALEX = alex +ALEX_OPTS = -g + +SRC = src +CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build + +all: parsers lexers + +parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs +lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs + +$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y + $(HAPPY) $(HAPPY_OPTS) $< -o $@ + +$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x + $(ALEX) $(ALEX_OPTS) $< -o $@ + +$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y + $(HAPPY) $(HAPPY_OPTS) $< -o $@ + +$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x + $(ALEX) $(ALEX_OPTS) $< -o $@ + diff --git a/README.md b/README.md index e393772..616061b 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,10 @@ `rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily imitating Haskell. +### Architecture + +![rlpc architecture diagram](/rlpc.drawio.svg) + ### Build Info * rlp is built using [Cabal](https://www.haskell.org/ghcup/) * rlp's documentation is built using [Sphinx](https://www.sphinx-doc.org/en/master/) @@ -18,32 +22,57 @@ $ cabal test --test-show-details=direct ``` ### Use + +#### TLDR + ```sh -# Compile and evaluate t.hs -$ rlpc t.hs -# Compile and evaluate t.hs, with evaluation info dumped to stderr -$ rlpc -ddump-eval t.hs -# Compile and evaluate t.hs, with evaluation info dumped to t.log -$ rlpc -ddump-eval -l t.log t.hs -# Print the raw structure describing the compiler options and die -# (option parsing still must succeed in order to print) -$ rlpc -ddump-opts t.hs +# Compile and evaluate examples/rlp/QuickSort.rl +$ rlpc examples/QuickSort.rl +# Compile and evaluate t.cr, with evaluation info dumped to t.log +$ rlpc -ddump-eval -l t.log t.cr +# Compile and evaluate t.rl, dumping the desugared Core +$ rlpc -ddump-desugared t.rl +# Compile and evaluate t.rl with all compiler messages enabled +$ rlpc -dALL t.rl ``` +#### Options + +```sh +Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG] + [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core] + FILES... +``` + +Available debug flags include: +* `-ddump-desugared`: dump Core generated from rl' +* `-ddump-parsed-core`: dump raw Core AST +* `-ddump-parsed`: dump raw rl' AST +* `-ddump-eval`: dump evaluation logs +* `-dALL`: disable debug message filtering. enables **all** debug messages + ### Potential Features Listed in order of importance. -- [ ] ADTs -- [ ] First-class functions -- [ ] Higher-kinded types +- [x] ADTs +- [x] First-class functions +- [x] Higher-kinded types - [ ] Typeclasses -- [ ] Parametric polymorphism -- [ ] Hindley-Milner type inference +- [x] Parametric polymorphism +- [x] Hindley-Milner type inference - [ ] Newtype coercion - [ ] Parallelism ### Milestones (This list is incomplete.) +Items are marked off not as they are 100% implemented, but rather once I +consider them stable enough that completion is soley a matter of getting +around to it -- no tough design decisions, theorising, etc. remain. For +example, as of writing this, the rl' frontend parser is not fully featured, +yet it is marked off on this list; finishing it would require cranking out +the remaining grammatical rules, and no work on complex tasks like layout +parsing remains. + - [ ] Backend - [x] Core language - [x] AST @@ -59,41 +88,78 @@ Listed in order of importance. - [x] Garbage Collection - [ ] Emitter - [ ] Code-gen (target yet to be decided) - - [ ] Core language emitter - - [ ] Core linter (Type-checker) - - [ ] Core2Core pass + - [x] Core linter (Type-checker) + - [ ] Core2Core pass (optimisations and misc. preprocessing) - [x] GM prep - [x] Non-strict case-floating - [ ] Let-floating - [ ] TCO - [ ] DCE - [ ] Frontend - - [ ] High-level language - - [ ] AST - - [ ] Lexer - - [ ] Parser - - [ ] Translation to the core language + - [x] High-level language + - [x] AST + - [x] Lexer + - [x] Parser + - [x] Translation to the core language - [ ] Constraint solver - [ ] `do`-notation - [x] CLI - [ ] Documentation - - [ ] State transition rules + - [x] State transition rules - [ ] How does the evaluation model work? + - [ ] The Hindley-Milner type system - [ ] CLI usage - [ ] Tail call optimisation - - [x] Parsing rlp + - [ ] Parsing rlp + - [ ] Trees That Grow - [ ] Tests - [x] Generic example programs - [ ] Parser -### December Release Plan -- [ ] Tests +### ~~December Release Plan~~ +- [x] Tests - [ ] Core lexer - [ ] Core parser - - [ ] Evaluation model + - [x] Evaluation model - [ ] Benchmarks -- [ ] Stable Core lexer -- [ ] Stable Core parser -- [ ] Stable evaluation model - - [ ] Garbage Collection +- [x] Stable Core lexer +- [x] Stable Core parser +- [x] Stable evaluation model + - [x] Garbage Collection - [ ] Stable documentation for the evaluation model + +### ~~February Release Plan~~ +- [x] Beta rl' to Core +- [x] UX improvements + - [x] Actual compiler errors -- no more unexceptional `error` calls + - [x] Better CLI dump flags + - [x] Annotate the AST with token positions for errors (NOTE: As of Feb. 1, + this has been done, but the locational info is not yet used in error messages) +- [x] Compiler architecture diagram +- [x] More examples + +### March Release Plan +- [ ] Tests + - [ ] rl' parser + - [ ] rl' lexer +- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free, + Cofree, etc. rather than boilerplate-heavy type families + +### Indefinite Release Plan + +This list is more concrete than the milestones, but likely further in the future +than the other release plans. + +- [ ] Overall codebase cleaning + - [ ] Complete all TODOs + - [ ] Replace mtl with effectful +- [ ] rl' type-checker +- [ ] Stable rl' to Core +- [ ] Core polish + - [ ] Better, stable parser + - [ ] Better, stable lexer + - [ ] Less hacky handling of named data + - [ ] Less hacky pragmas +- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders +- [ ] https://proglangdesign.net/wiki/challenges + diff --git a/app/CoreDriver.hs b/app/CoreDriver.hs new file mode 100644 index 0000000..2ded66e --- /dev/null +++ b/app/CoreDriver.hs @@ -0,0 +1,24 @@ +module CoreDriver + ( driver + ) + where +-------------------------------------------------------------------------------- +import Compiler.RLPC +import Control.Monad +import Data.Text qualified as T +import Lens.Micro.Platform + +import Core.Lex +import Core.Parse +import GM +-------------------------------------------------------------------------------- + +driver :: RLPCIO () +driver = forFiles_ $ \f -> + withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR) + +driverSource :: T.Text -> RLPCIO () +driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes + where + printRes = liftIO . print . view _1 + diff --git a/app/Main.hs b/app/Main.hs index 7b0b18d..5571352 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/RlpDriver.hs b/app/RlpDriver.hs new file mode 100644 index 0000000..89ad8d7 --- /dev/null +++ b/app/RlpDriver.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module RlpDriver + ( driver + ) + where +-------------------------------------------------------------------------------- +import Compiler.RLPC +import Control.Monad + +import Rlp.Lex +import Rlp.Parse +import Rlp2Core +import GM +-------------------------------------------------------------------------------- + +driver :: RLPCIO () +driver = forFiles_ $ \f -> + withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR) + diff --git a/doc/src/commentary/gm.rst b/doc/src/commentary/gm.rst index 1682a58..e471c95 100644 --- a/doc/src/commentary/gm.rst +++ b/doc/src/commentary/gm.rst @@ -1,16 +1,24 @@ The *G-Machine* =============== +The G-Machine (graph machine) is the current heart of rlpc, until we potentially +move onto a STG (spineless tagless graph machine) or a TIM (three-instruction +machine). rl' source code is desugared into Core; a dumbed-down subset of rl', +and then compiled to G-Machine code, which is then finally translated to the +desired target. + ********** Motivation ********** -Our initial model, the *Template Instantiator* (TI) was a very -straightforward solution to compilation, but its core design has a major -Achilles' heel, being that Compilation is interleaved with evaluation -- The -heap nodes for supercombinators hold uninstantiated expressions, i.e. raw ASTs -straight from the parser. When a supercombinator is found on the stack during -evaluation, the template expression is instantiated (compiled) on the spot. +Our initial model, the *Template Instantiator* (TI) was a very straightforward +solution to compilation, but its core design has a major Achilles' heel, being +that compilation is interleaved with evaluation -- The heap nodes for +supercombinators hold uninstantiated expressions, i.e. raw ASTs straight from +the parser. When a supercombinator is found on the stack during evaluation, the +template expression is instantiated (compiled) on the spot. This makes +translation to an assembly difficult, undermining the point of an intermediate +language. .. math:: \transrule @@ -31,7 +39,7 @@ evaluation, the template expression is instantiated (compiled) on the spot. \text{where } h' = \mathtt{instantiateU} \; e \; a_n \; h \; g } -The process of instantiating a supercombinator goes something like this +The process of instantiating a supercombinator goes something like this: 1. Augment the environment with bindings to the arguments. @@ -52,53 +60,16 @@ The process of instantiating a supercombinator goes something like this Instantiating the supercombinator's body in this way is the root of our Achilles' heel. Traversing a tree structure is a very non-linear task unfit for an assembly target. The goal of our new G-Machine is to compile a *linear -sequence of instructions* which instantiate the expression at execution. +sequence of instructions* which, **when executed**, build up a graph +representing the code. -************************** -Trees and Vines, in Theory -************************** - -WIP. - -************************** -Evaluation: Slurping Vines -************************** - -WIP. - -Laziness --------- - -WIP. - -* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind` - -**************************** -Compilation: Squashing Trees -**************************** - -WIP. - -Notice that we do not keep a (local) environment at run-time. The environment -only exists at compile-time to map local names to stack indices. When compiling -a supercombinator, the arguments are enumerated from zero (the top of the -stack), and passed to :code:`compileR` as an environment. +************* +The G-Machine +************* .. literalinclude:: /../../src/GM.hs :dedent: - :start-after: -- >> [ref/compileSc] - :end-before: -- << [ref/compileSc] + :start-after: -- >> [ref/Instr] + :end-before: -- << [ref/Instr] :caption: src/GM.hs -Of course, variables being indexed relative to the top of the stack means that -they will become inaccurate the moment we push or pop the stack a single time. -The way around this is quite simple: simply offset the stack when w - -.. literalinclude:: /../../src/GM.hs - :dedent: - :start-after: -- >> [ref/compileC] - :end-before: -- << [ref/compileC] - :caption: src/GM.hs - - - diff --git a/doc/src/commentary/layout-lexing.rst b/doc/src/commentary/layout-lexing.rst index 4fbfd5e..e000c3a 100644 --- a/doc/src/commentary/layout-lexing.rst +++ b/doc/src/commentary/layout-lexing.rst @@ -2,16 +2,21 @@ Lexing, Parsing, and Layouts ============================ The C-style languages of my previous experiences have all had quite trivial -lexical analysis stages, peaking in complexity when I streamed tokens lazily in -C. The task of tokenising a C-style language is very simple in description: you -ignore all whitespace and point out what you recognise. If you don't recognise -something, check if it's a literal or an identifier. Should it be neither, -return an error. +lexical analysis stages: you ignore all whitespace and point out the symbols you +recognise. If you don't recognise something, check if it's a literal or an +identifier. Should it be neither, return an error. -On paper, both lexing and parsing a Haskell-like language seem to pose a few +In contrast, both lexing and parsing a Haskell-like language poses a number of greater challenges. Listed by ascending intimidation factor, some of the potential roadblocks on my mind before making an attempt were: +* Context-sensitive keywords; Haskell allows for some words to be used as + identifiers in appropriate contexts, such as :code:`family`, :code:`role`, + :code:`as`. Reading a note_ found in `GHC's lexer`_, it appears that keywords + are only considered in bodies for which their use is relevant, e.g. + :code:`family` and :code:`role` in type declarations, :code:`as` after + :code:`case`; :code:`if`, :code:`then`, and :code:`else` in expressions, etc. + * Operators; Haskell has not only user-defined infix operators, but user-defined precedence levels and associativities. I recall using an algorithm that looked up infix, prefix, postfix, and even mixfix operators up in a global table to @@ -19,17 +24,9 @@ potential roadblocks on my mind before making an attempt were: stored in the table). I never modified the table at runtime, however this could be a very nice solution for Haskell. -* Context-sensitive keywords; Haskell allows for some words to be used as identifiers in - appropriate contexts, such as :code:`family`, :code:`role`, :code:`as`. - Reading a note_ found in `GHC's lexer`_, - it appears that keywords are only considered in bodies for which their use is - relevant, e.g. :code:`family` and :code:`role` in type declarations, - :code:`as` after :code:`case`; :code:`if`, :code:`then`, and :code:`else` in - expressions, etc. - * Whitespace sensitivity; While I was comfortable with the idea of a system - similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to - section code in a way that *felt* different. + similar to Python's INDENT/DEDENT tokens, Haskell's layout system is based on + alignment and is very generous with line-folding. .. _note: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes .. _GHC's lexer: https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Parser/Lexer.x#L1133 @@ -45,9 +42,9 @@ We will compare and contrast with Python's lexical analysis. Much to my dismay, Python uses newlines and indentation to separate statements and resolve scope instead of the traditional semicolons and braces found in C-style languages (we may generally refer to these C-style languages as *explicitly-sectioned*). -Internally during tokenisation, when the Python lexer begins a new line, they -compare the indentation of the new line with that of the previous and apply the -following rules: +Internally during tokenisation, when the Python lexer encounters a new line, the +indentation of the new line is compared with that of the previous and the +following rules are applied: 1. If the new line has greater indentation than the previous, insert an INDENT token and push the new line's indentation level onto the indentation stack @@ -60,170 +57,10 @@ following rules: 3. If the indentation is equal, insert a NEWLINE token to terminate the previous line, and leave it at that! -Parsing Python with the INDENT, DEDENT, and NEWLINE tokens is identical to -parsing a language with braces and semicolons. This is a solution pretty in line -with Python's philosophy of the "one correct answer" (TODO: this needs a -source). In developing our *layout* rules, we will follow in the pattern of -translating the whitespace-sensitive source language to an explicitly sectioned -language. - -But What About Haskell? -*********************** - -We saw that Python, the most notable example of an implicitly sectioned -language, is pretty simple to lex. Why then am I so afraid of Haskell's layouts? -To be frank, I'm far less scared after asking myself this -- however there are -certainly some new complexities that Python needn't concern. Haskell has -implicit line *continuation*: forms written over multiple lines; indentation -styles often seen in Haskell are somewhat esoteric compared to Python's -"s/[{};]//". - -.. code-block:: haskell - - -- line continuation - something = this is a - single expression - - -- an extremely common style found in haskell - data Python = Users - { are :: Crying - , right :: About - , now :: Sorry - } - - -- another formatting oddity - -- note that this is not a single - -- continued line! `look at`, - -- `this`, and `alignment` are all - -- separate expressions! - anotherThing = do look at - this - alignment - -But enough fear, lets actually think about implementation. Firstly, some -formality: what do we mean when we say layout? We will define layout as the -rules we apply to an implicitly-sectioned language in order to yield one that is -explicitly-sectioned. We will also define indentation of a lexeme as the column -number of its first character. - -Thankfully for us, our entry point is quite clear; layouts only appear after a -select few keywords, (with a minor exception; TODO: elaborate) being :code:`let` -(followed by supercombinators), :code:`where` (followed by supercombinators), -:code:`do` (followed by expressions), and :code:`of` (followed by alternatives) -(TODO: all of these terms need linked glossary entries). In order to manage the -cascade of layout contexts, our lexer will record a stack for which each element -is either :math:`\varnothing`, denoting an explicit layout written with braces -and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out -layout where the start of each item belonging to the layout is indented -:math:`n` columns. - -.. code-block:: haskell - - -- layout stack: [] - module M where -- layout stack: [∅] - - f x = let -- layout keyword; remember indentation of next token - y = w * w -- layout stack: [∅, <10>] - w = x + x - -- layout ends here - in do -- layout keyword; next token is a brace! - { -- layout stack: [∅] - print y; - print x; - } - -Finally, we also need the concept of "virtual" brace tokens, which as far as -we're concerned at this moment are exactly like normal brace tokens, except -implicitly inserted by the compiler. With the presented ideas in mind, we may -begin to introduce a small set of informal rules describing the lexer's handling -of layouts, the first being: - -1. If a layout keyword is followed by the token '{', push :math:`\varnothing` - onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto - the layout context stack where :math:`n` is the indentation of the token - following the layout keyword. Additionally, the lexer is to insert a virtual - opening brace after the token representing the layout keyword. - -Consider the following observations from that previous code sample: - -* Function definitions should belong to a layout, each of which may start at - column 1. - -* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and - the :code:`do`-expression. - -* Semicolons should *terminate* items, rather than *separate* them. - -Our current focus is the semicolons. In an implicit layout, items are on -separate lines each aligned with the previous. A naïve implementation would be -to insert the semicolon token when the EOL is reached, but this proves unideal -when you consider the alignment requirement. In our implementation, our lexer -will wait until the first token on a new line is reached, then compare -indentation and insert a semicolon if appropriate. This comparison -- the -nondescript measurement of "more, less, or equal indentation" rather than a -numeric value -- is referred to as *offside* by myself internally and the -Haskell report describing layouts. We informally formalise this rule as follows: - -2. When the first token on a line is preceeded only by whitespace, if the - token's first grapheme resides on a column number :math:`m` equal to the - indentation level of the enclosing context -- i.e. the :math:`\langle n - \rangle` on top of the layout stack. Should no such context exist on the - stack, assume :math:`m > n`. - -We have an idea of how to begin layouts, delimit the enclosed items, and last -we'll need to end layouts. This is where the distinction between virtual and -non-virtual brace tokens comes into play. The lexer needs only partial concern -towards closing layouts; the complete responsibility is shared with the parser. -This will be elaborated on in the next section. For now, we will be content with -naïvely inserting a virtual closing brace when a token is indented right of the -layout. - -3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall - insert a virtual closing brace and pop the layout stack. - -This rule covers some cases including the top-level, however, consider -tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis -framework only allows for lexing a single token at a time, we cannot return both -a virtual right-brace and a :code:`in`. Under this model, the lexer may simply -pop the layout stack and return the :code:`in` token. As we'll see in the next -section, as long as the lexer keeps track of its own context (i.e. the stack), -the parser will cope just fine without the virtual end-brace. - -Parsing Lonely Braces -********************* - -When viewed in the abstract, parsing and tokenising are near-identical tasks yet -the two are very often decomposed into discrete systems with very different -implementations. Lexers operate on streams of text and tokens, while parsers -are typically far less linear, using a parse stack or recursing top-down. A -big reason for this separation is state management: the parser aims to be as -context-free as possible, while the lexer tends to burden the necessary -statefulness. Still, the nature of a stream-oriented lexer makes backtracking -difficult and quite inelegant. - -However, simply declaring a parse error to be not an error at all -counterintuitively proves to be an elegant solution our layout problem which -minimises backtracking and state in both the lexer and the parser. Consider the -following definitions found in rlp's BNF: - -.. productionlist:: rlp - VOpen : `vopen` - VClose : `vclose` | `error` - -A parse error is recovered and treated as a closing brace. Another point of note -in the BNF is the difference between virtual and non-virtual braces (TODO: i -don't like that the BNF is formatted without newlines :/): - -.. productionlist:: rlp - LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr - -This ensures that non-virtual braces are closed explicitly. - -This set of rules is adequete enough to satisfy our basic concerns about line -continations and layout lists. For a more pedantic description of the layout -system, see `chapter 10 -`_ of the -2010 Haskell Report, which I heavily referenced here. +On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to +braces and semicolons. In developing our *layout* rules, we will follow in the +pattern of translating the whitespace-sensitive source language to an explicitly +sectioned language. References ---------- @@ -233,3 +70,4 @@ References * `Haskell syntax reference `_ + diff --git a/doc/src/commentary/ti.rst b/doc/src/commentary/ti.rst deleted file mode 100644 index 4e167d0..0000000 --- a/doc/src/commentary/ti.rst +++ /dev/null @@ -1,6 +0,0 @@ -The *Template Instantiator* -==================================== - -WIP. This will hopefully be expanded into a thorough walkthrough of the state -machine. - diff --git a/doc/src/commentary/type-inference.rst b/doc/src/commentary/type-inference.rst new file mode 100644 index 0000000..fa369bb --- /dev/null +++ b/doc/src/commentary/type-inference.rst @@ -0,0 +1,5 @@ +Type Inference in rl' +===================== + +rl' implements type inference via the Hindley-Milner type system. + diff --git a/doc/src/conf.py b/doc/src/conf.py index 1cd64cc..533296a 100644 --- a/doc/src/conf.py +++ b/doc/src/conf.py @@ -13,7 +13,7 @@ author = 'madeleine sydney slaga' # -- General configuration --------------------------------------------------- # https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration -extensions = ['sphinx.ext.imgmath'] +extensions = ['sphinx.ext.imgmath', 'sphinx.ext.graphviz'] # templates_path = ['_templates'] exclude_patterns = [] @@ -32,6 +32,7 @@ html_theme = 'alabaster' imgmath_latex_preamble = r''' \usepackage{amsmath} \usepackage{tabularray} +\usepackage{syntax} \newcommand{\transrule}[2] {\begin{tblr}{|rrrlc|} diff --git a/doc/src/references/rlp-grammar.rst b/doc/src/references/rlp-grammar.rst new file mode 100644 index 0000000..c81fea7 --- /dev/null +++ b/doc/src/references/rlp-grammar.rst @@ -0,0 +1,67 @@ +The Complete Syntax of rl' +========================== + +WIP. + +Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or +more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'. + +.. math + :nowrap: + + \setlength{\grammarparsep}{20pt plus 1pt minus 1pt} + \setlength{\grammarindent}{12em} + \begin{grammar} + ::= + \alt + \alt + \alt + + ::= `litint' + ::= `infix' + \alt `infixl' + \alt `infixr' + + ::= `data' `conname' {} + + \end{grammar} + +.. code-block:: bnf + + Decl ::= InfixDecl + | DataDecl + | TypeSig + | FunDef + + InfixDecl ::= InfixWord 'litint' Operator + InfixWord ::= 'infix' + | 'infixl' + | 'infixr' + + DataDecl ::= 'data' 'conname' {'name'} '=' Data + DataCons ::= 'conname' {Type1} ['|' DataCons] + + TypeSig ::= Var '::' Type + FunDef ::= Var {Pat1} '=' Expr + + Type ::= Type1 {Type1} + -- note that (->) is right-associative, + -- and extends as far as possible + | Type '->' Type + Type1 ::= '(' Type ')' + | 'conname' + + Pat ::= 'conname' Pat1 {Pat1} + | Pat 'consym' Pat + + Pat1 ::= Literal + | 'conname' + | '(' Pat ')' + + Literal ::= 'litint' + + Var ::= 'varname' + | '(' 'varsym' ')' + Con ::= 'conname' + | '(' 'consym' ')' + diff --git a/doc/src/references/rlp-inference-rules.rst b/doc/src/references/rlp-inference-rules.rst new file mode 100644 index 0000000..9520d0f --- /dev/null +++ b/doc/src/references/rlp-inference-rules.rst @@ -0,0 +1,17 @@ +rl' Inference Rules +=================== + +.. rubric:: + [Var] + +.. math:: + \frac{x : \tau \in \Gamma} + {\Gamma \vdash x : \tau} + +.. rubric:: + [App] + +.. math:: + \frac{\Gamma \vdash f : \alpha \to \beta \qquad \Gamma \vdash x : \alpha} + {\Gamma \vdash f x : \beta} + diff --git a/examples/Core/constDivZero.cr b/examples/Core/constDivZero.cr new file mode 100644 index 0000000..f25e208 --- /dev/null +++ b/examples/Core/constDivZero.cr @@ -0,0 +1,3 @@ +k x y = x; +main = k 3 (/# 1 0); + diff --git a/examples/factorial.hs b/examples/Core/factorial.cr similarity index 50% rename from examples/factorial.hs rename to examples/Core/factorial.cr index cc235ab..305e9d8 100644 --- a/examples/factorial.hs +++ b/examples/Core/factorial.cr @@ -1,6 +1,6 @@ fac n = case (==#) n 0 of - { 1 -> 1 - ; 0 -> (*#) n (fac ((-#) n 1)) + { <1> -> 1 + ; <0> -> *# n (fac (-# n 1)) }; main = fac 3; diff --git a/examples/Core/sumList.cr b/examples/Core/sumList.cr new file mode 100644 index 0000000..00b3659 --- /dev/null +++ b/examples/Core/sumList.cr @@ -0,0 +1,12 @@ +{-# PackData Nil 0 0 #-} +{-# PackData Cons 1 2 #-} + +foldr f z l = case l of + { Nil -> z + ; Cons x xs -> f x (foldr f z xs) + }; + +list = Cons 1 (Cons 2 (Cons 3 Nil)); + +main = foldr (+#) 0 list; + diff --git a/examples/constDivZero.hs b/examples/constDivZero.hs deleted file mode 100644 index da116f5..0000000 --- a/examples/constDivZero.hs +++ /dev/null @@ -1,3 +0,0 @@ -k x y = x; -main = k 3 ((/#) 1 0); - diff --git a/examples/rlp/QuickSort.rl b/examples/rlp/QuickSort.rl new file mode 100644 index 0000000..c374aa6 --- /dev/null +++ b/examples/rlp/QuickSort.rl @@ -0,0 +1,31 @@ +data List a = Nil | Cons a (List a) + +data Bool = False | True + +filter :: (a -> Bool) -> List a -> List a +filter p l = case l of + Nil -> Nil + Cons a as -> + case p a of + True -> Cons a (filter p as) + False -> filter p as + +append :: List a -> List a -> List a +append p q = case p of + Nil -> q + Cons a as -> Cons a (append as q) + +qsort :: List Int# -> List Int# +qsort l = case l of + Nil -> Nil + Cons a as -> + let lesser = filter (>=# a) as + greater = filter (<# a) as + in append (append (qsort lesser) (Cons a Nil)) (qsort greater) + +list :: List Int# +list = Cons 9 (Cons 2 (Cons 3 (Cons 2 + (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil))))))) + +main = print# (qsort list) + diff --git a/examples/rlp/SumList.rl b/examples/rlp/SumList.rl new file mode 100644 index 0000000..92cd410 --- /dev/null +++ b/examples/rlp/SumList.rl @@ -0,0 +1,11 @@ +data List a = Nil | Cons a (List a) + +foldr :: (a -> b -> b) -> b -> List a -> b +foldr f z l = case l of + Nil -> z + Cons a as -> f a (foldr f z as) + +list = Cons 1 (Cons 2 (Cons 3 Nil)) + +main = print# (foldr (+#) 0 list) + diff --git a/examples/sumList.hs b/examples/sumList.hs deleted file mode 100644 index fd46a60..0000000 --- a/examples/sumList.hs +++ /dev/null @@ -1,9 +0,0 @@ -nil = Pack{0 0}; -cons x y = Pack{1 2} x y; -list = cons 1 (cons 2 (cons 3 nil)); -sum l = case l of - { 0 -> 0 - ; 1 x xs -> (+#) x (sum xs) - }; -main = sum list; - diff --git a/programming-language-checklist b/programming-language-checklist new file mode 100644 index 0000000..cbc72ff --- /dev/null +++ b/programming-language-checklist @@ -0,0 +1,105 @@ +Programming Language Checklist +by Colin McMillen, Jason Reed, and Elly Fong-Jones, 2011-10-10. + +You appear to be advocating a new: +[x] functional [ ] imperative [ ] object-oriented [ ] procedural [ ] stack-based +[ ] "multi-paradigm" [x] lazy [ ] eager [x] statically-typed [ ] dynamically-typed +[x] pure [ ] impure [ ] non-hygienic [ ] visual [x] beginner-friendly +[ ] non-programmer-friendly [ ] completely incomprehensible +programming language. Your language will not work. Here is why it will not work. + +You appear to believe that: +[ ] Syntax is what makes programming difficult +[x] Garbage collection is free [x] Computers have infinite memory +[x] Nobody really needs: + [x] concurrency [x] a REPL [x] debugger support [x] IDE support [x] I/O + [x] to interact with code not written in your language +[ ] The entire world speaks 7-bit ASCII +[ ] Scaling up to large software projects will be easy +[ ] Convincing programmers to adopt a new language will be easy +[ ] Convincing programmers to adopt a language-specific IDE will be easy +[ ] Programmers love writing lots of boilerplate +[ ] Specifying behaviors as "undefined" means that programmers won't rely on them +[ ] "Spooky action at a distance" makes programming more fun + +Unfortunately, your language (has/lacks): +[x] comprehensible syntax [ ] semicolons [x] significant whitespace [ ] macros +[ ] implicit type conversion [ ] explicit casting [x] type inference +[ ] goto [ ] exceptions [x] closures [x] tail recursion [ ] coroutines +[ ] reflection [ ] subtyping [ ] multiple inheritance [x] operator overloading +[x] algebraic datatypes [x] recursive types [x] polymorphic types +[ ] covariant array typing [x] monads [ ] dependent types +[x] infix operators [x] nested comments [ ] multi-line strings [ ] regexes +[ ] call-by-value [x] call-by-name [ ] call-by-reference [ ] call-cc + +The following philosophical objections apply: +[ ] Programmers should not need to understand category theory to write "Hello, World!" +[ ] Programmers should not develop RSI from writing "Hello, World!" +[ ] The most significant program written in your language is its own compiler +[x] The most significant program written in your language isn't even its own compiler +[x] No language spec +[x] "The implementation is the spec" + [ ] The implementation is closed-source [ ] covered by patents [ ] not owned by you +[ ] Your type system is unsound [ ] Your language cannot be unambiguously parsed + [ ] a proof of same is attached + [ ] invoking this proof crashes the compiler +[x] The name of your language makes it impossible to find on Google +[x] Interpreted languages will never be as fast as C +[ ] Compiled languages will never be "extensible" +[ ] Writing a compiler that understands English is AI-complete +[ ] Your language relies on an optimization which has never been shown possible +[ ] There are less than 100 programmers on Earth smart enough to use your language +[ ] ____________________________ takes exponential time +[ ] ____________________________ is known to be undecidable + +Your implementation has the following flaws: +[ ] CPUs do not work that way +[ ] RAM does not work that way +[ ] VMs do not work that way +[ ] Compilers do not work that way +[ ] Compilers cannot work that way +[ ] Shift-reduce conflicts in parsing seem to be resolved using rand() +[ ] You require the compiler to be present at runtime +[ ] You require the language runtime to be present at compile-time +[ ] Your compiler errors are completely inscrutable +[ ] Dangerous behavior is only a warning +[ ] The compiler crashes if you look at it funny +[x] The VM crashes if you look at it funny +[x] You don't seem to understand basic optimization techniques +[x] You don't seem to understand basic systems programming +[ ] You don't seem to understand pointers +[ ] You don't seem to understand functions + +Additionally, your marketing has the following problems: +[x] Unsupported claims of increased productivity +[x] Unsupported claims of greater "ease of use" +[ ] Obviously rigged benchmarks + [ ] Graphics, simulation, or crypto benchmarks where your code just calls + handwritten assembly through your FFI + [ ] String-processing benchmarks where you just call PCRE + [ ] Matrix-math benchmarks where you just call BLAS +[x] Noone really believes that your language is faster than: + [x] assembly [x] C [x] FORTRAN [x] Java [x] Ruby [ ] Prolog +[ ] Rejection of orthodox programming-language theory without justification +[x] Rejection of orthodox systems programming without justification +[ ] Rejection of orthodox algorithmic theory without justification +[ ] Rejection of basic computer science without justification + +Taking the wider ecosystem into account, I would like to note that: +[x] Your complex sample code would be one line in: examples/ +[ ] We already have an unsafe imperative language +[ ] We already have a safe imperative OO language +[x] We already have a safe statically-typed eager functional language +[ ] You have reinvented Lisp but worse +[ ] You have reinvented Javascript but worse +[ ] You have reinvented Java but worse +[ ] You have reinvented C++ but worse +[ ] You have reinvented PHP but worse +[ ] You have reinvented PHP better, but that's still no justification +[ ] You have reinvented Brainfuck but non-ironically + +In conclusion, this is what I think of you: +[ ] You have some interesting ideas, but this won't fly. +[x] This is a bad language, and you should feel bad for inventing it. +[ ] Programming in this language is an adequate punishment for inventing it. + diff --git a/rlp.cabal b/rlp.cabal index 33c4d95..7ed9477 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -7,11 +7,12 @@ license: GPL-2.0-only -- license-file: LICENSE author: crumbtoo maintainer: crumb@disroot.org --- copyright: +copyright: Madeleine Sydney Ślaga category: Language build-type: Simple extra-doc-files: README.md -- extra-source-files: +tested-with: GHC==9.6.2 common warnings -- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds @@ -22,53 +23,89 @@ library , TI , GM , Compiler.RLPC + , Compiler.RlpcError + , Compiler.JustRun , Core.Syntax , Core.Examples , Core.Utils , Core.TH - - other-modules: Data.Heap + , Core.HindleyMilner + , Control.Monad.Errorful + , Rlp.Syntax + -- , Rlp.Parse.Decls + , Rlp.Parse + , Rlp.Parse.Associate + , Rlp.Lex + , Rlp.Parse.Types + , Rlp.TH + , Compiler.Types + , Data.Heap , Data.Pretty , Core.Parse , Core.Lex - , Control.Monad.Errorful , Core2Core - , RLP.Syntax + , Rlp2Core + , Control.Monad.Utils build-tool-depends: happy:happy, alex:alex -- other-extensions: - build-depends: base ^>=4.18.0.0 - , containers - , microlens - , microlens-th - , mtl - , template-haskell + build-depends: base >=4.17 && <4.20 -- required for happy - , array - , data-default-class - , unordered-containers - , hashable - , pretty - , recursion-schemes - , megaparsec - , text + , array >= 0.5.5 && < 0.6 + , containers >= 0.6.7 && < 0.7 + , template-haskell >= 2.20.0 && < 2.21 + , pretty >= 1.1.3 && < 1.2 + , data-default >= 0.7.1 && < 0.8 + , data-default-class >= 0.1.2 && < 0.2 + , hashable >= 1.4.3 && < 1.5 + , mtl >= 2.3.1 && < 2.4 + , text >= 2.0.2 && < 2.1 + , megaparsec >= 9.6.1 && < 9.7 + , microlens >= 0.4.13 && < 0.5 + , microlens-mtl >= 0.2.0 && < 0.3 + , microlens-platform >= 0.4.3 && < 0.5 + , microlens-th >= 0.4.3 && < 0.5 + , unordered-containers >= 0.2.20 && < 0.3 + , recursion-schemes >= 5.2.2 && < 5.3 + , data-fix >= 0.3.2 && < 0.4 + , utf8-string >= 1.0.2 && < 1.1 + , extra >= 1.7.0 && < 2 + , semigroupoids + , comonad + , lens + , text-ansi + , microlens-pro ^>=0.2.0 + , effectful-core ^>=2.3.0.0 + , deriving-compat ^>=0.6.0 + , these >=0.2 && <2.0 hs-source-dirs: src default-language: GHC2021 + default-extensions: + OverloadedStrings + TypeFamilies + LambdaCase + ViewPatterns + DataKinds + DerivingVia + StandaloneDeriving + DerivingStrategies + executable rlpc import: warnings main-is: Main.hs - -- other-modules: - -- other-extensions: - build-depends: base ^>=4.18.0.0 + other-modules: RlpDriver + , CoreDriver + + build-depends: base >=4.17.0.0 && <4.20.0.0 , rlp - , optparse-applicative - , microlens - , microlens-mtl - , mtl - , unordered-containers + , optparse-applicative >= 0.18.1 && < 0.19 + , microlens-platform + , mtl >= 2.3.1 && < 2.4 + , unordered-containers >= 0.2.20 && < 0.3 + , text >= 2.0.2 && < 2.1 hs-source-dirs: app default-language: GHC2021 @@ -84,7 +121,9 @@ test-suite rlp-test , rlp , QuickCheck , hspec ==2.* + , microlens other-modules: Arith , GMSpec + , Core.HindleyMilnerSpec build-tool-depends: hspec-discover:hspec-discover diff --git a/rlpc.drawio b/rlpc.drawio new file mode 100644 index 0000000..d68b067 --- /dev/null +++ b/rlpc.drawio @@ -0,0 +1,253 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/rlpc.drawio.svg b/rlpc.drawio.svg new file mode 100644 index 0000000..31dd37b --- /dev/null +++ b/rlpc.drawio.svg @@ -0,0 +1,4 @@ + + + +
rl' source code
RLPC
Parser
Rlp.Parse
(src/Rlp/Parse.y)
Rlp.Lex

(src/Rlp/Lex.x)
RlpToken
Rlp.Parse.Associate
RlpProgram' RlpcPs

(lexer & parser threaded w/ CPS)

Desugarer
Rlp2Core
Evaluation Model
GM
TM
TIM
STG
Preprocessing
Core2Core
tagData
defineData
liftNonStrictCases
Some target
Program'
Program'
[Instr]
Core Parser
Core.Lex
Core.Parse
CoreToken
Core Type-checker
(currently unimplemented)
Type-checker
RlpProgram' RlpcPs
RlpProgram' RlpcTc
Core.HindleyMilner
Program'
Program'
Core source code
???
 \ No newline at end of file diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs new file mode 100644 index 0000000..055062a --- /dev/null +++ b/src/Compiler/JustRun.hs @@ -0,0 +1,59 @@ +{-| +Module : Compiler.JustRun +Description : No-BS, high-level wrappers for major pipeline pieces. + +A collection of wrapper functions to demo processes such as lexing, parsing, +type-checking, and evaluation. This module intends to export "no-BS" functions +that use Prelude types such as @Either@ and @String@ rather than more complex +types such as @RLPC@ or @Text@. +-} +module Compiler.JustRun + ( justLexCore + , justParseCore + , justTypeCheckCore + , justHdbg + ) + where +---------------------------------------------------------------------------------- +import Core.Lex +import Core.Parse +import Core.HindleyMilner +import Core.Syntax (Program') +import Compiler.RLPC +import Control.Arrow ((>>>)) +import Control.Monad ((>=>), void) +import Control.Comonad +import Control.Lens +import Data.Text qualified as T +import Data.Function ((&)) +import System.IO +import GM +import Rlp.Parse +import Rlp2Core +---------------------------------------------------------------------------------- + +justHdbg :: String -> IO GmState +justHdbg s = do + p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s) + withFile "/tmp/t.log" WriteMode $ hdbgProg p + +justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken] +justLexCore s = lexCoreR (T.pack s) + & mapped . each %~ extract + & rlpcToEither + +justParseCore :: String -> Either [MsgEnvelope RlpcError] Program' +justParseCore s = parse (T.pack s) + & rlpcToEither + where parse = lexCoreR >=> parseCoreProgR + +justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program' +justTypeCheckCore s = typechk (T.pack s) + & rlpcToEither + where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR + +rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a +rlpcToEither r = case evalRLPC def r of + (Just a, _) -> Right a + (Nothing, es) -> Left es + diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 9cd1454..ec4b8bf 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -10,96 +10,116 @@ errors and the family of RLPC monads. {-# LANGUAGE TemplateHaskell #-} -- only used for mtl instances {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-} +{-# LANGUAGE BlockArguments, ViewPatterns #-} module Compiler.RLPC - ( RLPC - , RLPCT - , RLPCIO - , RLPCOptions(RLPCOptions) - , addFatal - , addWound - , MonadErrorful - , Severity(..) - , Evaluator(..) - , evalRLPCT - , evalRLPCIO - , evalRLPC - , rlpcLogFile - , rlpcDebugOpts - , rlpcEvaluator - , rlpcInputFiles - , DebugFlag(..) - , whenFlag - , flagDDumpEval - , flagDDumpOpts - , flagDDumpAST - , def + ( + -- * Rlpc Monad transformer + RLPCT(RLPCT), + -- ** Special cases + RLPC, RLPCIO + , liftIO + -- ** Running + , runRLPCT + , evalRLPCT, evalRLPCIO, evalRLPC + -- * Rlpc options + , Language(..), Evaluator(..) + , DebugFlag(..), CompilerFlag(..) + -- ** Lenses + , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage + -- * Misc. MTL-style functions + , liftErrorful, hoistRlpcT + -- * Misc. Rlpc Monad -related types + , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..) + , MsgEnvelope(..), Severity(..) + , addDebugMsg + , whenDFlag, whenFFlag + -- * Misc. Utilities + , forFiles_, withSource + -- * Convenient re-exports + , addFatal, addWound, def ) where ---------------------------------------------------------------------------------- import Control.Arrow ((>>>)) import Control.Exception +import Control.Monad import Control.Monad.Reader import Control.Monad.State (MonadState(state)) import Control.Monad.Errorful +import Control.Monad.IO.Class +import Compiler.RlpcError +import Compiler.Types import Data.Functor.Identity import Data.Default.Class +import Data.Foldable import GHC.Generics (Generic) +import Data.Maybe import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Data.HashSet qualified as S import Data.Coerce -import Lens.Micro -import Lens.Micro.TH +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.IO +import Text.ANSI qualified as Ansi +import Text.PrettyPrint hiding ((<>)) +import Lens.Micro.Platform +import Lens.Micro.Platform.Internal +import System.Exit ---------------------------------------------------------------------------------- --- TODO: fancy errors -newtype RLPCT e m a = RLPCT { - runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a +newtype RLPCT m a = RLPCT { + runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a } - -- TODO: incorrect ussage of MonadReader. RLPC should have its own - -- environment access functions - deriving (Functor, Applicative, Monad, MonadReader RLPCOptions) + deriving ( Functor, Applicative, Monad + , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError)) -deriving instance (MonadIO m) => MonadIO (RLPCT e m) +rlpc :: (IsRlpcError e, Monad m) + => (RLPCOptions -> (Maybe a, [MsgEnvelope e])) + -> RLPCT m a +rlpc f = RLPCT . ReaderT $ \opt -> + ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError -instance MonadTrans (RLPCT e) where +type RLPC = RLPCT Identity + +type RLPCIO = RLPCT IO + +instance MonadTrans RLPCT 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 - -evalRLPCT :: RLPCOptions - -> RLPCT e m a - -> m (Either e (a, [e])) -evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT +instance (MonadIO m) => MonadIO (RLPCT m) where + liftIO = lift . liftIO evalRLPC :: RLPCOptions - -> RLPC e a - -> Either e (a, [e]) -evalRLPC o m = coerce $ evalRLPCT o m + -> RLPC a + -> (Maybe a, [MsgEnvelope RlpcError]) +evalRLPC opt r = runRLPCT r + & flip runReaderT opt + & runErrorful -evalRLPCIO :: (Exception e) - => RLPCOptions - -> RLPCIO e a - -> IO (a, [e]) -evalRLPCIO o m = do - m' <- evalRLPCT o m - case m' of - -- TODO: errors - Left e -> throwIO e - Right a -> pure a - +evalRLPCT :: RLPCOptions + -> RLPCT m a + -> m (Maybe a, [MsgEnvelope RlpcError]) +evalRLPCT opt r = runRLPCT r + & flip runReaderT opt + & runErrorfulT + +liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a +liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) + +hoistRlpcT :: (forall a. m a -> n a) + -> RLPCT m a -> RLPCT n a +hoistRlpcT f rma = RLPCT $ ReaderT $ \opt -> + ErrorfulT $ f $ evalRLPCT opt rma data RLPCOptions = RLPCOptions { _rlpcLogFile :: Maybe FilePath - , _rlpcDebugOpts :: DebugOpts + , _rlpcDFlags :: HashSet DebugFlag + , _rlpcFFlags :: HashSet CompilerFlag , _rlpcEvaluator :: Evaluator , _rlpcHeapTrigger :: Int + , _rlpcLanguage :: Maybe Language , _rlpcInputFiles :: [FilePath] } deriving Show @@ -107,58 +127,126 @@ data RLPCOptions = RLPCOptions data Evaluator = EvaluatorGM | EvaluatorTI deriving Show -data Severity = Error - | Warning - | Debug - deriving Show - --- temporary until we have a new doc building system -type ErrorDoc = String - -class Diagnostic e where - errorDoc :: e -> ErrorDoc - -instance (Monad m) => MonadErrorful e (RLPCT e m) where - addWound = RLPCT . lift . addWound - addFatal = RLPCT . lift . addFatal +data Language = LanguageRlp | LanguageCore + deriving Show ---------------------------------------------------------------------------------- instance Default RLPCOptions where def = RLPCOptions { _rlpcLogFile = Nothing - , _rlpcDebugOpts = mempty + , _rlpcDFlags = mempty + , _rlpcFFlags = mempty , _rlpcEvaluator = EvaluatorGM , _rlpcHeapTrigger = 200 , _rlpcInputFiles = [] + , _rlpcLanguage = Nothing } -type DebugOpts = HashSet DebugFlag +-- debug flags are passed with -dFLAG +type DebugFlag = Text -data DebugFlag = DDumpEval - | DDumpOpts - | DDumpAST - deriving (Show, Eq, Generic) - -instance Hashable DebugFlag +type CompilerFlag = Text makeLenses ''RLPCOptions pure [] -whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m () -whenFlag l m = asks (^. l) >>= \a -> if a then m else pure () +addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m () +addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed] --- there's probably a better way to write this. my current knowledge of lenses --- is too weak. -flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool -flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d +-- TODO: rewrite this with prisms once microlens-pro drops :3 +whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m () +whenDFlag f m = do + -- mfw no `At` instance for HashSet + fs <- view rlpcDFlags + let a = S.member f fs + when a m -flagDDumpEval :: SimpleGetter RLPCOptions Bool -flagDDumpEval = flagGetter DDumpEval +whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m () +whenFFlag f m = do + -- mfw no `At` instance for HashSet + fs <- view rlpcFFlags + let a = S.member f fs + when a m -flagDDumpOpts :: SimpleGetter RLPCOptions Bool -flagDDumpOpts = flagGetter DDumpOpts +-------------------------------------------------------------------------------- -flagDDumpAST :: SimpleGetter RLPCOptions Bool -flagDDumpAST = flagGetter DDumpAST +evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a +evalRLPCIO opt r = do + (ma,es) <- evalRLPCT opt r + putRlpcErrs opt es + case ma of + Just x -> pure x + Nothing -> die "Failed, no code compiled." + +putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO () +putRlpcErrs opt es = case opt ^. rlpcLogFile of + Just lf -> withFile lf WriteMode putter + Nothing -> putter stderr + where + putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es + +renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String] +renderRlpcErrs opts = (if don'tBother then id else filter byTag) + >>> fmap prettyRlpcMsg + where + dflags = opts ^. rlpcDFlags + don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags) + + byTag :: MsgEnvelope RlpcError -> Bool + byTag (view msgSeverity -> SevDebug t) = + t `S.member` dflags + byTag _ = True + +prettyRlpcMsg :: MsgEnvelope RlpcError -> String +prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m +prettyRlpcMsg m = render $ docRlpcErr m + +prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String +prettyRlpcDebugMsg msg = + T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ] + where + mkLine s = "-d" <> tag <> ": " <> s <> "\n" + Text ts = msg ^. msgDiagnostic + SevDebug tag = msg ^. msgSeverity + +docRlpcErr :: MsgEnvelope RlpcError -> Doc +docRlpcErr msg = header + $$ nest 2 bullets + $$ source + where + source = vcat $ zipWith (<+>) rule srclines + where + rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|") + srclines = ["", "", ""] + filename = msgColour "" + pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine) + <> ":" + <> tshow (msg ^. msgSpan . srcspanColumn) + + header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": " + <> errorColour "error" <> msgColour ":" + + bullets = let Text ts = msg ^. msgDiagnostic + in vcat $ hang "•" 2 . ttext . msgColour <$> ts + + msgColour = Ansi.white . Ansi.bold + errorColour = Ansi.red . Ansi.bold + ttext = text . T.unpack + tshow :: (Show a) => a -> Text + tshow = T.pack . show + +-------------------------------------------------------------------------------- + +forFiles_ :: (Monad m) + => (FilePath -> RLPCT m a) + -> RLPCT m () +forFiles_ k = do + fs <- view rlpcInputFiles + forM_ fs k + +-- TODO: catch any exceptions, i.e. non-existent files should be handled by the +-- compiler +withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a +withSource f k = liftIO (T.readFile f) >>= k diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs new file mode 100644 index 0000000..a8ef710 --- /dev/null +++ b/src/Compiler/RlpcError.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Compiler.RlpcError + ( IsRlpcError(..) + , MsgEnvelope(..) + , Severity(..) + , RlpcError(..) + , msgSpan + , msgDiagnostic + , msgSeverity + , liftRlpcErrors + , errorMsg + , debugMsg + -- * Located Comonad + , Located(..) + , SrcSpan(..) + ) + where +---------------------------------------------------------------------------------- +import Control.Monad.Errorful +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Exts (IsString(..)) +import Lens.Micro.Platform +import Lens.Micro.Platform.Internal +import Compiler.Types +---------------------------------------------------------------------------------- + +data MsgEnvelope e = MsgEnvelope + { _msgSpan :: SrcSpan + , _msgDiagnostic :: e + , _msgSeverity :: Severity + } + deriving (Functor, Show) + +newtype RlpcError = Text [Text] + deriving Show + +instance IsString RlpcError where + fromString = Text . pure . T.pack + +class IsRlpcError e where + liftRlpcError :: e -> RlpcError + +instance IsRlpcError RlpcError where + liftRlpcError = id + +data Severity = SevWarning + | SevError + | SevDebug Text -- ^ Tag + deriving Show + +makeLenses ''MsgEnvelope + +liftRlpcErrors :: (Functor m, IsRlpcError e) + => ErrorfulT e m a + -> ErrorfulT RlpcError m a +liftRlpcErrors = mapErrorful liftRlpcError + +instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where + liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError + +errorMsg :: SrcSpan -> e -> MsgEnvelope e +errorMsg s e = MsgEnvelope + { _msgSpan = s + , _msgDiagnostic = e + , _msgSeverity = SevError + } + +debugMsg :: Text -> e -> MsgEnvelope e +debugMsg tag e = MsgEnvelope + -- TODO: not pretty, but it is a debug message after all + { _msgSpan = SrcSpan 0 0 0 0 + , _msgDiagnostic = e + , _msgSeverity = SevDebug tag + } + diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs new file mode 100644 index 0000000..607a0db --- /dev/null +++ b/src/Compiler/Types.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} +module Compiler.Types + ( SrcSpan(..) + , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen + , Located(..) + , _Located + , located + , nolo + , (<<~), (<~>), (<#>) + + -- * Re-exports + , Comonad + , Apply + , Bind + ) + where +-------------------------------------------------------------------------------- +import Control.Comonad +import Data.Functor.Apply +import Data.Functor.Bind +import Control.Lens hiding ((<<~)) +import Language.Haskell.TH.Syntax (Lift) +-------------------------------------------------------------------------------- + +-- | Token wrapped with a span (line, column, absolute, length) +data Located a = Located SrcSpan a + deriving (Show, Lift, Functor) + +located :: Lens (Located a) (Located b) a b +located = lens extract ($>) + +instance Apply Located where + liftF2 f (Located sa p) (Located sb q) + = Located (sa <> sb) (p `f` q) + +instance Bind Located where + Located sa a >>- k = Located (sa <> sb) b + where + Located sb b = k a + +instance Comonad Located where + extract (Located _ a) = a + extend ck w@(Located p _) = Located p (ck w) + +data SrcSpan = SrcSpan + !Int -- ^ Line + !Int -- ^ Column + !Int -- ^ Absolute + !Int -- ^ Length + deriving (Show, Lift) + +tupling :: Iso' SrcSpan (Int, Int, Int, Int) +tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d)) + (\ (a,b,c,d) -> SrcSpan a b c d) + +srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int +srcspanLine = tupling . _1 +srcspanColumn = tupling . _2 +srcspanAbs = tupling . _3 +srcspanLen = tupling . _4 + +-- | debug tool +nolo :: a -> Located a +nolo = Located (SrcSpan 0 0 0 0) + +instance Semigroup SrcSpan where + SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where + l = min la lb + c = min ca cb + a = min aa ab + s = case aa `compare` ab of + EQ -> max sa sb + LT -> max sa (ab + lb - aa) + GT -> max sb (aa + la - ab) + +-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for +-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style. + +(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b +(<<~) = (<<=) + +infixl 4 <<~ + +-- | Similar to '(<*>)', but with a cokleisli arrow. + +(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b +mc <~> ma = mc >>- \f -> ma =>> f + +infixl 4 <~> + +-- this is getting silly + +(<#>) :: (Functor f) => f (a -> b) -> a -> f b +fab <#> a = fmap ($ a) fab + +infixl 4 <#> + +makePrisms ''Located + diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index bcfd4a3..1d46e91 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -1,65 +1,87 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TupleSections, PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} module Control.Monad.Errorful - ( ErrorfulT - , runErrorfulT + ( ErrorfulT(..) , Errorful + , pattern Errorful + , errorful , runErrorful + , mapErrorful + , hoistErrorfulT , MonadErrorful(..) ) where ---------------------------------------------------------------------------------- +import Control.Monad.State.Strict +import Control.Monad.Reader import Control.Monad.Trans import Data.Functor.Identity import Data.Coerce +import Data.HashSet (HashSet) +import Data.HashSet qualified as H import Lens.Micro ---------------------------------------------------------------------------------- -newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) } +newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) } type Errorful e = ErrorfulT e Identity -pattern Errorful :: (Either e (a, [e])) -> Errorful e a +pattern Errorful :: (Maybe a, [e]) -> Errorful e a pattern Errorful a = ErrorfulT (Identity a) -runErrorful :: Errorful e a -> Either e (a, [e]) +errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a +errorful = ErrorfulT . pure + +runErrorful :: Errorful e a -> (Maybe a, [e]) runErrorful m = coerce (runErrorfulT m) class (Applicative m) => MonadErrorful e m | m -> e where - addWound :: e -> m () - addFatal :: e -> m a - - -- not sure if i want to add this yet... - -- catchWound :: m a -> (e -> m a) -> m a + addWound :: e -> m () + addFatal :: e -> m a instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where - addWound e = ErrorfulT $ pure . Right $ ((), [e]) - addFatal e = ErrorfulT $ pure . Left $ e + addWound e = ErrorfulT $ pure (Just (), [e]) + addFatal e = ErrorfulT $ pure (Nothing, [e]) instance MonadTrans (ErrorfulT e) where - lift m = ErrorfulT (Right . (,[]) <$> m) + lift m = ErrorfulT ((\x -> (Just x,[])) <$> 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 + fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f) instance (Applicative m) => Applicative (ErrorfulT e m) where - pure a = ErrorfulT (pure . Right $ (a, [])) + pure a = ErrorfulT . pure $ (Just a, []) - m <*> a = ErrorfulT (m' `apply` a') - where - m' = runErrorfulT m - a' = runErrorfulT a - -- TODO: strict concatenation - apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2)) + ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where + apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e]) + apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2) instance (Monad m) => Monad (ErrorfulT e m) where ErrorfulT m >>= k = ErrorfulT $ do - m' <- m - case m' of - Right (a,es) -> runErrorfulT (k a) - Left e -> pure (Left e) + (a,es) <- m + case a of + Just x -> runErrorfulT (k x) <&> _2 %~ (es<>) + Nothing -> pure (Nothing, es) + +mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a +mapErrorful f (ErrorfulT m) = ErrorfulT $ + m <&> _2 . mapped %~ f + +-- when microlens-pro drops we can write this as +-- mapErrorful f = coerced . mapped . _2 . mapped %~ f +-- lol + +hoistErrorfulT :: (forall a. m a -> n a) -> ErrorfulT e m a -> ErrorfulT e n a +hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m) + +-------------------------------------------------------------------------------- +-- daily dose of n^2 instances + +instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where + addWound = lift . addWound + addFatal = lift . addFatal diff --git a/src/Control/Monad/Utils.hs b/src/Control/Monad/Utils.hs new file mode 100644 index 0000000..d09e91a --- /dev/null +++ b/src/Control/Monad/Utils.hs @@ -0,0 +1,37 @@ +module Control.Monad.Utils + ( mapAccumLM + , Kendo(..) + , generalise + ) + where +---------------------------------------------------------------------------------- +import Data.Tuple (swap) +import Data.Coerce +import Data.Functor.Identity +import Control.Monad.State +import Control.Monad +---------------------------------------------------------------------------------- + +-- | Monadic variant of @mapAccumL@ + +mapAccumLM :: forall m t s a b. (Monad m, Traversable t) + => (s -> a -> m (s, b)) + -> s + -> t a + -> m (s, t b) +mapAccumLM k s t = swap <$> runStateT (traverse k' t) s + where + k' :: a -> StateT s m b + k' a = StateT $ fmap swap <$> flip k a + +newtype Kendo m a = Kendo { appKendo :: a -> m a } + +instance (Monad m) => Semigroup (Kendo m a) where + Kendo f <> Kendo g = Kendo (f <=< g) + +instance (Monad m) => Monoid (Kendo m a) where + mempty = Kendo pure + +generalise :: (Monad m) => Identity a -> m a +generalise (Identity a) = pure a + diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 430a94f..b13abe5 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -4,18 +4,18 @@ Description : Core examples (may eventually be unit tests) -} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Core.Examples - ( fac3 - , sumList - , constDivZero - , idCase - ) where +module Core.Examples where ---------------------------------------------------------------------------------- import Core.Syntax import Core.TH ---------------------------------------------------------------------------------- --- TODO: my shitty lexer isn't inserting semicolons +-- fac3 = undefined +-- sumList = undefined +-- constDivZero = undefined +-- idCase = undefined + +--- letrecExample :: Program' letrecExample = [coreProg| @@ -76,12 +76,12 @@ negExample3 = [coreProg| arithExample1 :: Program' arithExample1 = [coreProg| - main = (+#) 3 (negate# 2); + main = +# 3 (negate# 2); |] arithExample2 :: Program' arithExample2 = [coreProg| - main = negate# ((+#) 2 ((*#) 5 3)); + main = negate# (+# 2 (*# 5 3)); |] ifExample1 :: Program' @@ -96,7 +96,7 @@ ifExample2 = [coreProg| facExample :: Program' facExample = [coreProg| - fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1))); + fac n = if# (==# n 0) 1 (*# n (fac (-# n 1))); main = fac 3; |] @@ -142,21 +142,21 @@ simple1 = [coreProg| caseBool1 :: Program' caseBool1 = [coreProg| _if c x y = case c of - { 1 -> x - ; 0 -> y + { <1> -> x + ; <0> -> y }; false = Pack{0 0}; true = Pack{1 0}; - main = _if false ((+#) 2 3) ((*#) 4 5); + main = _if false (+# 2 3) (*# 4 5); |] fac3 :: Program' fac3 = [coreProg| - fac n = case (==#) n 0 of - { 1 -> 1 - ; 0 -> (*#) n (fac ((-#) n 1)) + fac n = case ==# n 0 of + { <1> -> 1 + ; <0> -> *# n (fac (-# n 1)) }; main = fac 3; @@ -170,8 +170,8 @@ sumList = [coreProg| cons x y = Pack{1 2} x y; list = cons 1 (cons 2 (cons 3 nil)); sum l = case l of - { 0 -> 0 - ; 1 x xs -> (+#) x (sum xs) + { <0> -> 0 + ; <1> x xs -> +# x (sum xs) }; main = sum list; |] @@ -179,7 +179,7 @@ sumList = [coreProg| constDivZero :: Program' constDivZero = [coreProg| k x y = x; - main = k 3 ((/#) 1 0); + main = k 3 (/# 1 0); |] idCase :: Program' @@ -187,34 +187,60 @@ idCase = [coreProg| id x = x; main = id (case Pack{1 0} of - { 1 -> (+#) 2 3 + { <1> -> +# 2 3 }) |] -corePrelude :: Module Name -corePrelude = Module (Just ("Prelude", [])) $ - -- non-primitive defs - [coreProg| - id x = x; - k x y = x; - k1 x y = y; - s f g x = f x (g x); - compose f g x = f (g x); - twice f x = f (f x); - fst p = casePair# p k; - snd p = casePair# p k1; - head l = caseList# l abort# k; - tail l = caseList# l abort# k1; - _length_cc x xs = (+#) 1 (length xs); - length l = caseList# l 0 length_cc; +-- NOTE: the GM primitive (==#) returns an untyped constructor with tag 1 for +-- true, and 0 for false. See: GM.boxBool +namedBoolCase :: Program' +namedBoolCase = [coreProg| + {-# PackData True 1 0 #-} + {-# PackData False 0 0 #-} + main = case ==# 1 1 of + { True -> 123 + ; False -> 456 + } |] - <> - -- primitive constructors need some specialised wiring: - Program - [ ScDef "False" [] $ Con 0 0 - , ScDef "True" [] $ Con 1 0 - , ScDef "MkPair" [] $ Con 0 2 - , ScDef "Nil" [] $ Con 1 0 - , ScDef "Cons" [] $ Con 2 2 - ] + +namedConsCase :: Program' +namedConsCase = [coreProg| + {-# PackData Nil 0 0 #-} + {-# PackData Cons 1 2 #-} + foldr f z l = case l of + { Nil -> z + ; Cons x xs -> f x (foldr f z xs) + }; + list = Cons 1 (Cons 2 (Cons 3 Nil)); + main = foldr (+#) 0 list + |] + +-- corePrelude :: Module Name +-- corePrelude = Module (Just ("Prelude", [])) $ +-- -- non-primitive defs +-- [coreProg| +-- id x = x; +-- k x y = x; +-- k1 x y = y; +-- s f g x = f x (g x); +-- compose f g x = f (g x); +-- twice f x = f (f x); +-- fst p = casePair# p k; +-- snd p = casePair# p k1; +-- head l = caseList# l abort# k; +-- tail l = caseList# l abort# k1; +-- _length_cc x xs = (+#) 1 (length xs); +-- length l = caseList# l 0 length_cc; +-- |] +-- <> +-- -- primitive constructors need some specialised wiring: +-- Program +-- [ ScDef "False" [] $ Con 0 0 +-- , ScDef "True" [] $ Con 1 0 +-- , ScDef "MkPair" [] $ Con 0 2 +-- , ScDef "Nil" [] $ Con 1 0 +-- , ScDef "Cons" [] $ Con 2 2 +-- ] + +--} diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs new file mode 100644 index 0000000..17d7118 --- /dev/null +++ b/src/Core/HindleyMilner.hs @@ -0,0 +1,280 @@ +{-| +Module : Core.HindleyMilner +Description : Hindley-Milner type system +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Core.HindleyMilner + ( Context' + , infer + , check + , checkCoreProg + , checkCoreProgR + , checkCoreExprR + , TypeError(..) + , HMError + ) + where +---------------------------------------------------------------------------------- +import Lens.Micro +import Lens.Micro.Mtl +import Lens.Micro.Platform +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Pretty (rpretty) +import Data.HashMap.Strict qualified as H +import Data.Foldable (traverse_) +import Data.Functor +import Data.Functor.Identity +import Compiler.RLPC +import Compiler.Types +import Compiler.RlpcError +import Control.Monad (foldM, void, forM) +import Control.Monad.Errorful +import Control.Monad.State +import Control.Monad.Utils (mapAccumLM, generalise) +import Text.Printf +import Core.Syntax +---------------------------------------------------------------------------------- + +-- | Annotated typing context -- I have a feeling we're going to want this in the +-- future. +type Context b = [(b, Type)] + +-- | Unannotated typing context, AKA our beloved Γ. +type Context' = Context Name + +-- | Type error enum. +data TypeError + -- | Two types could not be unified + = TyErrCouldNotUnify Type Type + -- | @x@ could not be unified with @t@ because @x@ occurs in @t@ + | TyErrRecursiveType Name Type + -- | Untyped, potentially undefined variable + | TyErrUntypedVariable Name + | TyErrMissingTypeSig Name + deriving (Show, Eq) + +instance IsRlpcError TypeError where + liftRlpcError = \case + -- todo: use anti-parser instead of show + TyErrCouldNotUnify t u -> Text + [ T.pack $ printf "Could not match type `%s` with `%s`." + (rpretty @String t) (rpretty @String u) + , "Expected: " <> rpretty t + , "Got: " <> rpretty u + ] + TyErrUntypedVariable n -> Text + [ "Untyped (likely undefined) variable `" <> n <> "`" + ] + TyErrRecursiveType t x -> Text + [ T.pack $ printf "Recursive type: `%s' occurs in `%s'" + (rpretty @String t) (rpretty @String x) + ] + +-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may +-- throw any number of fatal or nonfatal errors. Run with @runErrorful@. +type HMError = Errorful TypeError + +-- | Assert that an expression unifies with a given type +-- +-- >>> let e = [coreProg|3|] +-- >>> check [] (TyCon "Bool") e +-- Left (TyErrCouldNotUnify (TyCon "Bool") (TyCon "Int#")) +-- >>> check [] (TyCon "Int#") e +-- Right () + +check :: Context' -> Type -> Expr' -> HMError () +check g t1 e = do + t2 <- infer g e + void $ unify [(t1,t2)] + +-- | Typecheck program. I plan to allow for *some* inference in the future, but +-- in the mean time all top-level binders must have a type annotation. +checkCoreProg :: Program' -> HMError () +checkCoreProg p = scDefs + & traverse_ k + where + scDefs = p ^. programScDefs + g = gatherTypeSigs p + + k :: ScDef' -> HMError () + k sc = case lookup scname g of + Just t -> check g t (sc ^. _rhs) + Nothing -> addFatal $ TyErrMissingTypeSig scname + where scname = sc ^. _lhs._1 + +-- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks. +checkCoreProgR :: forall m. (Monad m) => Program' -> RLPCT m Program' +checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p) + $> p + where + liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0)) + +checkCoreExprR :: (Monad m) => Context' -> Expr' -> RLPCT m Expr' +checkCoreExprR g e = (hoistRlpcT generalise . liftE . infer g $ e) + $> e + where + liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0)) + +-- | Infer the type of an expression under some context. +-- +-- >>> let g1 = [("id", TyVar "a" :-> TyVar "a")] +-- >>> let g2 = [("id", (TyVar "a" :-> TyVar "a") :-> TyVar "a" :-> TyVar "a")] +-- >>> infer g1 [coreExpr|id 3|] +-- Right TyInt +-- >>> infer g2 [coreExpr|id 3|] +-- Left (TyErrCouldNotUnify (TyVar "a" :-> TyVar "a") TyInt) + +infer :: Context' -> Expr' -> HMError Type +infer g e = do + (t,cs) <- gather g e + -- apply all unified constraints + foldr (uncurry subst) t <$> unify cs + +-- | A @Constraint@ between two types describes the requirement that the pair +-- must unify +type Constraint = (Type, Type) + +-- | Type of an expression under some context, and gather the constraints +-- necessary to unify. Note that this is not the same as @infer@, as the +-- expression will likely be given a fresh type variable along with a +-- constraint, rather than the solved type. +-- +-- For example, if the context says "@id@ has type a -> a," in an application of +-- @id 3@, the whole application is assigned type @$a0@ and the constraint that +-- @id@ must unify with type @Int -> $a0@ is generated. +-- +-- >>> gather [("id", TyVar "a" :-> TyVar "a")] [coreExpr|id 3|] +-- (TyVar "$a0",[(TyVar "a" :-> TyVar "a",TyInt :-> TyVar "$a0")]) + +gather :: Context' -> Expr' -> HMError (Type, [Constraint]) +gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where + go :: Context' -> Expr' -> StateT ([Constraint], Int) HMError Type + go g = \case + Lit (IntL _) -> pure TyInt + Var k -> lift $ maybe e pure $ lookup k g + where e = addFatal $ TyErrUntypedVariable k + App f x -> do + tf <- go g f + tx <- go g x + tfx <- uniqueVar + addConstraint tf (tx :-> tfx) + pure tfx + Let NonRec bs e -> do + g' <- buildLetContext g bs + go g' e + Let Rec bs e -> do + g' <- buildLetrecContext g bs + go g' e + Lam bs e -> case bs of + [x] -> do + tx <- uniqueVar + let g' = (x,tx) : g + te <- go g' e + pure (tx :-> te) + -- TODO lambda, case + + buildLetrecContext :: Context' -> [Binding'] + -> StateT ([Constraint], Int) HMError Context' + buildLetrecContext g bs = do + let f ag (k := _) = do + n <- uniqueVar + pure ((k,n) : ag) + rg <- foldM f g bs + let k ag (k := v) = do + t <- go rg v + pure ((k,t) : ag) + foldM k g bs + + -- | augment a context with the inferred types of each binder. the returned + -- context is linearly accumulated, meaning that the context used to infer each binder + -- will include the inferred types of all previous binder + + buildLetContext :: Context' -> [Binding'] + -> StateT ([Constraint], Int) HMError Context' + buildLetContext = foldM k where + k :: Context' -> Binding' -> StateT ([Constraint], Int) HMError Context' + k g (x := y) = do + ty <- go g y + pure ((x,ty) : g) + +uniqueVar :: StateT ([Constraint], Int) HMError Type +uniqueVar = do + n <- use _2 + _2 %= succ + pure (TyVar . T.pack $ '$' : 'a' : show n) + +addConstraint :: Type -> Type -> StateT ([Constraint], Int) HMError () +addConstraint t u = _1 %= ((t, u):) + +-- | Unify a list of constraints, meaning that pairs between types are turned +-- into pairs of type variables and types. A useful thought model is to think of +-- it as solving an equation such that the unknown variable is the left-hand +-- side. + +unify :: [Constraint] -> HMError Context' +unify = go mempty where + go :: Context' -> [Constraint] -> HMError Context' + + -- nothing left! return accumulated context + go g [] = pure g + + go g (c:cs) = case c of + -- primitives may of course unify with themselves + (TyInt, TyInt) -> go g cs + + -- `x` unifies with `x` + (TyVar t, TyVar u) | t == u -> go g cs + + -- a type variable `x` unifies with an arbitrary type `t` if `t` does + -- not reference `x` + (TyVar x, t) -> unifyTV g x t cs + (t, TyVar x) -> unifyTV g x t cs + + -- two functions may be unified if their domain and codomain unify + (a :-> b, x :-> y) -> go g $ (a,x) : (b,y) : cs + + -- anything else is a failure :( + (t,u) -> addFatal $ TyErrCouldNotUnify t u + + unifyTV :: Context' -> Name -> Type -> [Constraint] -> HMError Context' + unifyTV g x t cs | occurs t = addFatal $ TyErrRecursiveType x t + | otherwise = go g' substed + where + g' = (x,t) : g + substed = cs & each . both %~ subst x t + + occurs (a :-> b) = occurs a || occurs b + occurs (TyVar y) + | x == y = True + occurs _ = False + +gatherTypeSigs :: Program b -> Context b +gatherTypeSigs p = p ^. programTypeSigs + & H.toList + +-- | The expression @subst x t e@ substitutes all occurences of @x@ in @e@ with +-- @t@ +-- +-- >>> subst "a" (TyCon "Int") (TyVar "a") +-- TyCon "Int" +-- >>> subst "a" (TyCon "Int") (TyVar "a" :-> TyVar "a") +-- TyCon "Int" :-> TyCon "Int" + +subst :: Name -> Type -> Type -> Type +subst x t (TyVar y) | x == y = t +subst x t (a :-> b) = subst x t a :-> subst x t b +subst _ _ e = e + +-------------------------------------------------------------------------------- + +demoContext :: Context' +demoContext = + [ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a") + , ("add", TyInt :-> TyInt :-> TyInt) + , ("==", TyInt :-> TyInt :-> TyCon "Bool") + , ("True", TyCon "Bool") + , ("False", TyCon "Bool") + ] + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index b666d69..f62fb8d 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -3,8 +3,10 @@ Module : Core.Lex Description : Lexical analysis for the core language -} +{-# LANGUAGE OverloadedStrings #-} module Core.Lex ( lexCore + , lexCoreR , lexCore' , CoreToken(..) , SrcError(..) @@ -15,13 +17,20 @@ module Core.Lex where import Data.Char (chr) import Debug.Trace +import Data.Text (Text) +import Data.Text qualified as T +import Data.String (IsString(..)) +import Data.Functor.Identity import Core.Syntax import Compiler.RLPC +import Compiler.Types +-- TODO: unify Located definitions +import Compiler.RlpcError import Lens.Micro import Lens.Micro.TH } -%wrapper "monad" +%wrapper "monad-strict-text" $whitechar = [ \t\n\r\f\v] $special = [\(\)\,\;\[\]\{\}] @@ -59,6 +68,8 @@ $white_no_nl = $white # $nl @decimal = $digit+ +@alttag = "<" $digit+ ">" + rlp :- <0> @@ -68,6 +79,7 @@ rlp :- "{" { constTok TokenLBrace } "}" { constTok TokenRBrace } ";" { constTok TokenSemicolon } + "::" { constTok TokenHasType } "@" { constTok TokenTypeApp } "{-#" { constTok TokenLPragma `andBegin` pragma } @@ -80,17 +92,19 @@ rlp :- "where" { constTok TokenWhere } "Pack" { constTok TokenPack } -- temp - "\\" { constTok TokenLambda } + "\" { constTok TokenLambda } "λ" { constTok TokenLambda } "=" { constTok TokenEquals } "->" { constTok TokenArrow } + @alttag { lexWith ( TokenAltTag . read @Int . T.unpack + . T.drop 1 . T.init ) } @varname { lexWith TokenVarName } @conname { lexWith TokenConName } @varsym { lexWith TokenVarSym } @consym { lexWith TokenConSym } - @decimal { lexWith (TokenLitInt . read @Int) } + @decimal { lexWith (TokenLitInt . read @Int . T.unpack) } $white { skip } \n { skip } @@ -107,11 +121,9 @@ rlp :- } { -data Located a = Located Int Int Int a - deriving Show constTok :: t -> AlexInput -> Int -> Alex (Located t) -constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t +constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t data CoreToken = TokenLet | TokenLetrec @@ -128,16 +140,18 @@ data CoreToken = TokenLet | TokenConName Name | TokenVarSym Name | TokenConSym Name + | TokenAltTag Tag | TokenEquals | TokenLParen | TokenRParen | TokenLBrace | TokenRBrace | TokenSemicolon + | TokenHasType | TokenTypeApp | TokenLPragma | TokenRPragma - | TokenWord String + | TokenWord Text | TokenEOF deriving Show @@ -155,42 +169,51 @@ data SrcErrorType = SrcErrLexical String type Lexer = AlexInput -> Int -> Alex (Located CoreToken) -lexWith :: (String -> CoreToken) -> Lexer -lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) +lexWith :: (Text -> CoreToken) -> Lexer +lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s -- | The main lexer driver. -lexCore :: String -> RLPC SrcError [Located CoreToken] +lexCore :: Text -> RLPC [Located CoreToken] lexCore s = case m of - Left e -> addFatal err - where err = SrcError - { _errSpan = (0,0,0) -- TODO: location - , _errSeverity = Error - , _errDiagnostic = SrcErrLexical e - } + Left e -> error "core lex error" Right ts -> pure ts where m = runAlex s lexStream +lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken] +lexCoreR = hoistRlpcT generalise . lexCore + where + generalise :: forall a. Identity a -> m a + generalise (Identity a) = pure a + -- | @lexCore@, but the tokens are stripped of location info. Useful for -- debugging -lexCore' :: String -> RLPC SrcError [CoreToken] +lexCore' :: Text -> RLPC [CoreToken] lexCore' s = fmap f <$> lexCore s - where f (Located _ _ _ t) = t + where f (Located _ t) = t lexStream :: Alex [Located CoreToken] lexStream = do l <- alexMonadScan case l of - Located _ _ _ TokenEOF -> pure [l] - _ -> (l:) <$> lexStream + Located _ TokenEOF -> pure [l] + _ -> (l:) <$> lexStream data ParseError = ParErrLexical String | ParErrParse deriving Show +-- TODO: +instance IsRlpcError SrcError where + liftRlpcError = Text . pure . T.pack . show + +-- TODO: +instance IsRlpcError ParseError where + liftRlpcError = Text . pure . T.pack . show + alexEOF :: Alex (Located CoreToken) alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> - Right (st, Located y x 0 TokenEOF) + Right (st, nolo $ TokenEOF) } diff --git a/src/Core/Lex.x.old b/src/Core/Lex.x.old deleted file mode 100644 index 0aebd64..0000000 --- a/src/Core/Lex.x.old +++ /dev/null @@ -1,315 +0,0 @@ -{ --- TODO: layout semicolons are not inserted at EOf. -{-# LANGUAGE TemplateHaskell #-} -module Core.Lex - ( lexCore - , lexCore' - , CoreToken(..) - , ParseError(..) - , Located(..) - , AlexPosn(..) - ) - where -import Data.Char (chr) -import Debug.Trace -import Core.Syntax -import Compiler.RLPC -import Lens.Micro -import Lens.Micro.TH -} - -%wrapper "monadUserState" - -$whitechar = [ \t\n\r\f\v] -$special = [\(\)\,\;\[\]\{\}] - -$digit = 0-9 - -$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] -$unisymbol = [] -- TODO -$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\'] - -$large = [A-Z \xc0-\xd6 \xd8-\xde] -$small = [a-z \xdf-\xf6 \xf8-\xff \_] -$alpha = [$small $large] - -$graphic = [$small $large $symbol $digit $special \:\"\'] - -$octit = 0-7 -$hexit = [0-9 A-F a-f] -$namechar = [$alpha $digit \' \#] -$symchar = [$symbol \:] -$nl = [\n\r] -$white_no_nl = $white # $nl - -@reservedid = - case|data|do|import|in|let|letrec|module|of|where - -@reservedop = - "=" | \\ | "->" - -@varname = $small $namechar* -@conname = $large $namechar* -@varsym = $symbol $symchar* -@consym = \: $symchar* - -@decimal = $digit+ - -rlp :- - --- everywhere: skip whitespace -$white_no_nl+ { skip } - --- TODO: `--` could begin an operator -"--"[^$nl]* { skip } -"--"\-*[^$symbol].* { skip } - -"{-" { nestedComment } - --- syntactic symbols -<0> -{ - "(" { constTok TokenLParen } - ")" { constTok TokenRParen } - "{" { lbrace } - "}" { rbrace } - ";" { constTok TokenSemicolon } - "," { constTok TokenComma } -} - --- keywords --- see commentary on the layout system -<0> -{ - "let" { constTok TokenLet `andBegin` layout } - "letrec" { constTok TokenLetrec `andBegin` layout } - "of" { constTok TokenOf `andBegin` layout } - "case" { constTok TokenCase } - "module" { constTok TokenModule } - "in" { letin } - "where" { constTok TokenWhere `andBegin` layout } -} - --- reserved symbols -<0> -{ - "=" { constTok TokenEquals } - "->" { constTok TokenArrow } -} - --- identifiers -<0> -{ - -- TODO: qualified names - @varname { lexWith TokenVarName } - @conname { lexWith TokenConName } - @varsym { lexWith TokenVarSym } -} - --- literals -<0> -{ - @decimal { lexWith (TokenLitInt . read @Int) } -} - -<0> \n { begin bol } - - -{ - $white { skip } - \n { skip } - () { topLevelOff `andBegin` 0 } -} - - -{ - \n { skip } - () { doBol `andBegin` 0 } -} - - -{ - $white { skip } - \{ { lbrace `andBegin` 0 } - () { noBrace `andBegin` 0 } -} - -{ -data Located a = Located Int Int Int a - deriving Show - -constTok :: t -> AlexInput -> Int -> Alex (Located t) -constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t - -data CoreToken = TokenLet - | TokenLetrec - | TokenIn - | TokenModule - | TokenWhere - | TokenComma - | TokenCase - | TokenOf - | TokenLambda - | TokenArrow - | TokenLitInt Int - | TokenVarName Name - | TokenConName Name - | TokenVarSym Name - | TokenConSym Name - | TokenEquals - | TokenLParen - | TokenRParen - | TokenLBrace - | TokenRBrace - | TokenLBraceV -- virtual brace inserted by layout - | TokenRBraceV -- virtual brace inserted by layout - | TokenIndent Int - | TokenDedent Int - | TokenSemicolon - | TokenEOF - deriving Show - -data LayoutContext = Layout Int - | NoLayout - deriving Show - -data AlexUserState = AlexUserState - { _ausContext :: [LayoutContext] - } - -ausContext :: Lens' AlexUserState [LayoutContext] -ausContext f (AlexUserState ctx) - = fmap - (\a -> AlexUserState a) (f ctx) -{-# INLINE ausContext #-} - -pushContext :: LayoutContext -> Alex () -pushContext c = do - st <- alexGetUserState - alexSetUserState $ st { _ausContext = c : _ausContext st } - -popContext :: Alex () -popContext = do - st <- alexGetUserState - alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) } - -getContext :: Alex [LayoutContext] -getContext = do - st <- alexGetUserState - pure $ _ausContext st - -type Lexer = AlexInput -> Int -> Alex (Located CoreToken) - -alexInitUserState :: AlexUserState -alexInitUserState = AlexUserState [] - -nestedComment :: Lexer -nestedComment _ _ = undefined - -lexStream :: Alex [Located CoreToken] -lexStream = do - l <- alexMonadScan - case l of - Located _ _ _ TokenEOF -> pure [l] - _ -> (l:) <$> lexStream - --- | The main lexer driver. -lexCore :: String -> RLPC ParseError [Located CoreToken] -lexCore s = case m of - Left e -> addFatal err - where err = SrcError - { _errSpan = (0,0,0) -- TODO: location - , _errSeverity = Error - , _errDiagnostic = ParErrLexical e - } - Right ts -> pure ts - where - m = runAlex s (alexSetStartCode initial *> lexStream) - --- | @lexCore@, but the tokens are stripped of location info. Useful for --- debugging -lexCore' :: String -> RLPC ParseError [CoreToken] -lexCore' s = fmap f <$> lexCore s - where f (Located _ _ _ t) = t - -data ParseError = ParErrLexical String - | ParErrParse - deriving Show - -lexWith :: (String -> CoreToken) -> Lexer -lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) - -lexToken :: Alex (Located CoreToken) -lexToken = alexMonadScan - -getSrcCol :: Alex Int -getSrcCol = Alex $ \ st -> - let AlexPn _ _ col = alex_pos st - in Right (st, col) - -lbrace :: Lexer -lbrace (AlexPn _ y x,_,_,_) l = do - pushContext NoLayout - pure $ Located y x l TokenLBrace - -rbrace :: Lexer -rbrace (AlexPn _ y x,_,_,_) l = do - popContext - pure $ Located y x l TokenRBrace - -insRBraceV :: AlexPosn -> Alex (Located CoreToken) -insRBraceV (AlexPn _ y x) = do - popContext - pure $ Located y x 0 TokenRBraceV - -insSemi :: AlexPosn -> Alex (Located CoreToken) -insSemi (AlexPn _ y x) = do - pure $ Located y x 0 TokenSemicolon - -modifyUst :: (AlexUserState -> AlexUserState) -> Alex () -modifyUst f = do - st <- alexGetUserState - alexSetUserState $ f st - -getUst :: Alex AlexUserState -getUst = alexGetUserState - -newLayoutContext :: Lexer -newLayoutContext (p,_,_,_) _ = do - undefined - -noBrace :: Lexer -noBrace (AlexPn _ y x,_,_,_) l = do - col <- getSrcCol - pushContext (Layout col) - pure $ Located y x l TokenLBraceV - -getOffside :: Alex Ordering -getOffside = do - ctx <- getContext - m <- getSrcCol - case ctx of - Layout n : _ -> pure $ m `compare` n - _ -> pure GT - -doBol :: Lexer -doBol (p,c,_,s) _ = do - off <- getOffside - case off of - LT -> insRBraceV p - EQ -> insSemi p - _ -> lexToken - -letin :: Lexer -letin (AlexPn _ y x,_,_,_) l = do - popContext - pure $ Located y x l TokenIn - -topLevelOff :: Lexer -topLevelOff = noBrace - -alexEOF :: Alex (Located CoreToken) -alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> - Right (st, Located y x 0 TokenEOF) - -} diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 94d0dcc..fcb6e2c 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -3,23 +3,35 @@ Module : Core.Parse Description : Parser for the Core language -} +{-# LANGUAGE OverloadedStrings, ViewPatterns #-} module Core.Parse ( parseCore , parseCoreExpr + , parseCoreExprR , parseCoreProg + , parseCoreProgR , module Core.Lex -- temp convenience - , parseTmp , SrcError , Module ) where import Control.Monad ((>=>)) +import Control.Monad.Utils (generalise) import Data.Foldable (foldl') +import Data.Functor.Identity import Core.Syntax import Core.Lex import Compiler.RLPC +import Control.Monad +import Lens.Micro import Data.Default.Class (def) +import Data.Hashable (Hashable) +import Data.List.Extra +import Data.Text.IO qualified as TIO +import Data.Text (Text) +import Data.Text qualified as T +import Data.HashMap.Strict qualified as H } %name parseCore Module @@ -27,35 +39,37 @@ import Data.Default.Class (def) %name parseCoreProg StandaloneProgram %tokentype { Located CoreToken } %error { parseError } -%monad { RLPC SrcError } +%monad { RLPC } { happyBind } { happyPure } %token - let { Located _ _ _ TokenLet } - letrec { Located _ _ _ TokenLetrec } - module { Located _ _ _ TokenModule } - where { Located _ _ _ TokenWhere } - case { Located _ _ _ TokenCase } - of { Located _ _ _ TokenOf } - pack { Located _ _ _ TokenPack } -- temp - in { Located _ _ _ TokenIn } - litint { Located _ _ _ (TokenLitInt $$) } - varname { Located _ _ _ (TokenVarName $$) } - varsym { Located _ _ _ (TokenVarSym $$) } - conname { Located _ _ _ (TokenConName $$) } - consym { Located _ _ _ (TokenConSym $$) } - word { Located _ _ _ (TokenWord $$) } - 'λ' { Located _ _ _ TokenLambda } - '->' { Located _ _ _ TokenArrow } - '=' { Located _ _ _ TokenEquals } - '@' { Located _ _ _ TokenTypeApp } - '(' { Located _ _ _ TokenLParen } - ')' { Located _ _ _ TokenRParen } - '{' { Located _ _ _ TokenLBrace } - '}' { Located _ _ _ TokenRBrace } - '{-#' { Located _ _ _ TokenLPragma } - '#-}' { Located _ _ _ TokenRPragma } - ';' { Located _ _ _ TokenSemicolon } - eof { Located _ _ _ TokenEOF } + let { Located _ TokenLet } + letrec { Located _ TokenLetrec } + module { Located _ TokenModule } + where { Located _ TokenWhere } + case { Located _ TokenCase } + of { Located _ TokenOf } + pack { Located _ TokenPack } -- temp + in { Located _ TokenIn } + litint { Located _ (TokenLitInt $$) } + varname { Located _ (TokenVarName $$) } + varsym { Located _ (TokenVarSym $$) } + conname { Located _ (TokenConName $$) } + consym { Located _ (TokenConSym $$) } + alttag { Located _ (TokenAltTag $$) } + word { Located _ (TokenWord $$) } + 'λ' { Located _ TokenLambda } + '->' { Located _ TokenArrow } + '=' { Located _ TokenEquals } + '@' { Located _ TokenTypeApp } + '(' { Located _ TokenLParen } + ')' { Located _ TokenRParen } + '{' { Located _ TokenLBrace } + '}' { Located _ TokenRBrace } + '{-#' { Located _ TokenLPragma } + '#-}' { Located _ TokenRPragma } + ';' { Located _ TokenSemicolon } + '::' { Located _ TokenHasType } + eof { Located _ TokenEOF } %% @@ -71,16 +85,46 @@ StandaloneProgram :: { Program Name } StandaloneProgram : Program eof { $1 } Program :: { Program Name } -Program : ScDefs { Program $1 } +Program : ScTypeSig ';' Program { insTypeSig $1 $3 } + | ScTypeSig OptSemi { singletonTypeSig $1 } + | ScDef ';' Program { insScDef $1 $3 } + | ScDef OptSemi { singletonScDef $1 } + | TLPragma Program {% doTLPragma $1 $2 } + | TLPragma {% doTLPragma $1 mempty } + +TLPragma :: { Pragma } + : '{-#' Words '#-}' { Pragma $2 } + +Words :: { [Text] } + : Words word { $1 `snoc` $2 } + | word { [$1] } + +OptSemi :: { () } +OptSemi : ';' { () } + | {- epsilon -} { () } + +ScTypeSig :: { (Name, Type) } +ScTypeSig : Var '::' Type { ($1,$3) } ScDefs :: { [ScDef Name] } ScDefs : ScDef ';' ScDefs { $1 : $3 } | ScDef ';' { [$1] } | ScDef { [$1] } - | {- epsilon -} { [] } ScDef :: { ScDef Name } ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } + -- hack to allow constructors to be compiled into scs + | Con ParList '=' Expr { ScDef $1 $2 $4 } + +Type :: { Type } +Type : Type1 { $1 } + +Type1 :: { Type } +Type1 : '(' Type ')' { $2 } + | Type1 '->' Type { $1 :-> $3 } + -- do we want to allow symbolic names for tyvars and tycons? + | varname { TyVar $1 } + | conname { TyCon $1 } ParList :: { [Name] } ParList : Var ParList { $1 : $2 } @@ -120,22 +164,15 @@ Alters : Alter ';' Alters { $1 : $3 } | Alter { [$1] } Alter :: { Alter Name } -Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 } +Alter : alttag ParList '->' Expr { Alter (AltTag $1) $2 $4 } + | Con ParList '->' Expr { Alter (AltData $1) $2 $4 } Expr1 :: { Expr Name } -Expr1 : litint { LitE $ IntL $1 } +Expr1 : litint { Lit $ IntL $1 } | Id { Var $1 } | PackCon { $1 } - | ExprPragma { $1 } | '(' Expr ')' { $2 } -ExprPragma :: { Expr Name } -ExprPragma : '{-#' Words '#-}' {% exprPragma $2 } - -Words :: { [String] } -Words : word Words { $1 : $2 } - | word { [$1] } - PackCon :: { Expr Name } PackCon : pack '{' litint litint '}' { Con $3 $4 } @@ -152,43 +189,73 @@ Id : Var { $1 } | Con { $1 } Var :: { Name } -Var : '(' varsym ')' { $2 } - | varname { $1 } +Var : varname { $1 } + | varsym { $1 } Con :: { Name } -Con : '(' consym ')' { $2 } - | conname { $1 } +Con : conname { $1 } + | consym { $1 } { -parseError :: [Located CoreToken] -> RLPC SrcError a -parseError (Located y x l _ : _) = addFatal err - where err = SrcError - { _errSpan = (y,x,l) - , _errSeverity = Error - , _errDiagnostic = SrcErrParse - } +parseError :: [Located CoreToken] -> RLPC a +parseError (Located _ t : _) = + error $ "" <> ":" <> "" + <> ": parse error at token `" <> show t <> "'" -parseTmp :: IO (Module Name) -parseTmp = do - s <- readFile "/tmp/t.hs" - case parse s of - Left e -> error (show e) - Right (ts,_) -> pure ts +{-# WARNING parseError "unimpl" #-} + +exprPragma :: [String] -> RLPC (Expr Name) +exprPragma ("AST" : e) = undefined +exprPragma _ = undefined + +{-# WARNING exprPragma "unimpl" #-} + +astPragma :: [String] -> RLPC (Expr Name) +astPragma _ = undefined + +{-# WARNING astPragma "unimpl" #-} + +insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b +insTypeSig ts = programTypeSigs %~ uncurry H.insert ts + +singletonTypeSig :: (Hashable b) => (b, Type) -> Program b +singletonTypeSig ts = insTypeSig ts mempty + +insScDef :: (Hashable b) => ScDef b -> Program b -> Program b +insScDef sc = programScDefs %~ (sc:) + +singletonScDef :: (Hashable b) => ScDef b -> Program b +singletonScDef sc = insScDef sc mempty + +parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr' +parseCoreExprR = hoistRlpcT generalise . parseCoreExpr + +parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program' +parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg) where - parse = evalRLPC def . (lexCore >=> parseCore) + ddumpast :: Program' -> RLPCT m Program' + ddumpast p = do + addDebugMsg "dump-parsed-core" . show $ p + pure p -exprPragma :: [String] -> RLPC SrcError (Expr Name) -exprPragma ("AST" : e) = astPragma e -exprPragma _ = addFatal err - where err = SrcError - { _errSpan = (0,0,0) -- TODO: span - , _errSeverity = Warning - , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma - } +happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b +happyBind m k = m >>= k -astPragma :: [String] -> RLPC SrcError (Expr Name) -astPragma = pure . read . unwords +happyPure :: a -> RLPC a +happyPure a = pure a + +doTLPragma :: Pragma -> Program' -> RLPC Program' +-- TODO: warn unrecognised pragma +doTLPragma (Pragma []) p = pure p + +doTLPragma (Pragma pr) p = case pr of + -- TODO: warn on overwrite + ["PackData", n, readt -> t, readt -> a] -> + pure $ p & programDataTags . at n ?~ (t,a) + +readt :: (Read a) => Text -> a +readt = read . T.unpack } diff --git a/src/Core/Parse.y.old b/src/Core/Parse.y.old deleted file mode 100644 index bacd40e..0000000 --- a/src/Core/Parse.y.old +++ /dev/null @@ -1,159 +0,0 @@ -{ -module Core.Parse - ( parseCore - , parseCoreExpr - , parseCoreProg - , module Core.Lex -- temp convenience - , parseTmp - , SrcError - , ParseError - , Module - ) - where - -import Control.Monad ((>=>)) -import Data.Foldable (foldl') -import Core.Syntax -import Core.Lex -import Compiler.RLPC -import Data.Default.Class (def) -} - -%name parseCore Module -%name parseCoreExpr StandaloneExpr -%name parseCoreProg StandaloneProgram -%tokentype { Located CoreToken } -%error { parseError } -%monad { RLPC ParseError } - -%token - let { Located _ _ _ TokenLet } - letrec { Located _ _ _ TokenLetrec } - module { Located _ _ _ TokenModule } - where { Located _ _ _ TokenWhere } - ',' { Located _ _ _ TokenComma } - in { Located _ _ _ TokenIn } - litint { Located _ _ _ (TokenLitInt $$) } - varname { Located _ _ _ (TokenVarName $$) } - varsym { Located _ _ _ (TokenVarSym $$) } - conname { Located _ _ _ (TokenConName $$) } - consym { Located _ _ _ (TokenConSym $$) } - 'λ' { Located _ _ _ TokenLambda } - '->' { Located _ _ _ TokenArrow } - '=' { Located _ _ _ TokenEquals } - '(' { Located _ _ _ TokenLParen } - ')' { Located _ _ _ TokenRParen } - '{' { Located _ _ _ TokenLBrace } - '}' { Located _ _ _ TokenRBrace } - vl { Located _ _ _ TokenLBraceV } - vr { Located _ _ _ TokenRBraceV } - ';' { Located _ _ _ TokenSemicolon } - eof { Located _ _ _ TokenEOF } - -%% - -Module :: { Module } -Module : module conname where Program Eof { Module (Just ($2, [])) $4 } - | Program Eof { Module Nothing $1 } - -Eof :: { () } -Eof : eof { () } - | error { () } - -StandaloneProgram :: { Program } -StandaloneProgram : Program eof { $1 } - -Program :: { Program } -Program : VOpen ScDefs VClose { Program $2 } - | '{' ScDefs '}' { Program $2 } - -VOpen :: { () } -VOpen : vl { () } - -VClose :: { () } -VClose : vr { () } - | error { () } - -ScDefs :: { [ScDef] } -ScDefs : ScDef ';' ScDefs { $1 : $3 } - | {- epsilon -} { [] } - -ScDef :: { ScDef } -ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } - -ParList :: { [Name] } -ParList : Var ParList { $1 : $2 } - | {- epsilon -} { [] } - -StandaloneExpr :: { Expr } -StandaloneExpr : Expr eof { $1 } - -Expr :: { Expr } -Expr : LetExpr { $1 } - | 'λ' Binders '->' Expr { Lam $2 $4 } - | Application { $1 } - | Expr1 { $1 } - -LetExpr :: { Expr } -LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 } - | letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 } - | let '{' Bindings '}' in Expr { Let NonRec $3 $6 } - | letrec '{' Bindings '}' in Expr { Let Rec $3 $6 } - -Binders :: { [Name] } -Binders : Var Binders { $1 : $2 } - | Var { [$1] } - -Application :: { Expr } -Application : Expr1 AppArgs { foldl' App $1 $2 } - --- TODO: Application can probably be written as a single rule, without AppArgs -AppArgs :: { [Expr] } -AppArgs : Expr1 AppArgs { $1 : $2 } - | Expr1 { [$1] } - -Expr1 :: { Expr } -Expr1 : litint { IntE $1 } - | Id { Var $1 } - | '(' Expr ')' { $2 } - -Bindings :: { [Binding] } -Bindings : Binding ';' Bindings { $1 : $3 } - | Binding ';' { [$1] } - | Binding { [$1] } - -Binding :: { Binding } -Binding : Var '=' Expr { $1 := $3 } - -Id :: { Name } -Id : Var { $1 } - | Con { $1 } - -Var :: { Name } -Var : '(' varsym ')' { $2 } - | varname { $1 } - -Con :: { Name } -Con : '(' consym ')' { $2 } - | conname { $1 } - -{ -parseError :: [Located CoreToken] -> RLPC ParseError a -parseError (Located y x l _ : _) = addFatal err - where err = SrcError - { _errSpan = (y,x,l) - , _errSeverity = Error - , _errDiagnostic = ParErrParse - } - -parseTmp :: IO Module -parseTmp = do - s <- readFile "/tmp/t.hs" - case parse s of - Left e -> error (show e) - Right (ts,_) -> pure ts - where - parse = evalRLPC def . (lexCore >=> parseCore) - -} - diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 676cf3b..c7bc9ee 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -4,11 +4,19 @@ Description : Core ASTs and the like -} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} +-- for recursion-schemes +{-# LANGUAGE DeriveTraversable, TypeFamilies #-} module Core.Syntax ( Expr(..) + , ExprF(..) + , ExprF'(..) , Type(..) - , Literal(..) + , pattern TyInt + , Lit(..) , pattern (:$) + , pattern (:@) + , pattern (:->) , Binding(..) , AltCon(..) , pattern (:=) @@ -20,52 +28,75 @@ module Core.Syntax , Module(..) , Program(..) , Program' + , Pragma(..) + , unliftScDef , programScDefs + , programTypeSigs + , programDataTags , Expr' , ScDef' , Alter' , Binding' , HasRHS(_rhs) , HasLHS(_lhs) + , Pretty(pretty) ) where ---------------------------------------------------------------------------------- import Data.Coerce import Data.Pretty -import GHC.Generics import Data.List (intersperse) import Data.Function ((&)) +import Data.Functor.Foldable +import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.String +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as H +import Data.Hashable +import Data.Text qualified as T +import Data.Char +import Data.These +import Data.Bifoldable (bifoldr) +import GHC.Generics (Generic, Generically(..)) -- Lift instances for the Core quasiquoters import Language.Haskell.TH.Syntax (Lift) -import Lens.Micro +-- import Lens.Micro.TH (makeLenses) +-- import Lens.Micro +import Control.Lens ---------------------------------------------------------------------------------- data Expr b = Var Name - | Con Tag Int -- Con Tag Arity + | Con Tag Int -- ^ Con Tag Arity | Case (Expr b) [Alter b] | Lam [b] (Expr b) | Let Rec [Binding b] (Expr b) | App (Expr b) (Expr b) - | LitE Literal - | Type Type + | Lit Lit deriving (Show, Read, Lift) deriving instance (Eq b) => Eq (Expr b) -data Type = TyInt - | TyFun +data Type = TyFun | TyVar Name | TyApp Type Type - | TyConApp TyCon [Type] + | TyCon Name deriving (Show, Read, Lift, Eq) -type TyCon = Name +pattern TyInt :: Type +pattern TyInt = TyCon "Int#" infixl 2 :$ -pattern (:$) :: Expr b -> Expr b -> Expr b +pattern (:$) :: Expr b -> Expr b -> Expr b pattern f :$ x = App f x +infixl 2 :@ +pattern (:@) :: Type -> Type -> Type +pattern f :@ x = TyApp f x + +infixr 1 :-> +pattern (:->) :: Type -> Type -> Type +pattern a :-> b = TyApp (TyApp TyFun a) b + {-# COMPLETE Binding :: Binding #-} {-# COMPLETE (:=) :: Binding #-} data Binding b = Binding b (Expr b) @@ -74,7 +105,7 @@ data Binding b = Binding b (Expr b) deriving instance (Eq b) => Eq (Binding b) infixl 1 := -pattern (:=) :: b -> (Expr b) -> (Binding b) +pattern (:=) :: b -> Expr b -> Binding b pattern k := v = Binding k v data Alter b = Alter AltCon [b] (Expr b) @@ -82,32 +113,54 @@ data Alter b = Alter AltCon [b] (Expr b) deriving instance (Eq b) => Eq (Alter b) +newtype Pragma = Pragma [T.Text] + data Rec = Rec | NonRec deriving (Show, Read, Eq, Lift) -data AltCon = AltData Tag - | AltLiteral Literal - | Default +data AltCon = AltData Name + | AltTag Tag + | AltLit Lit + | AltDefault deriving (Show, Read, Eq, Lift) -data Literal = IntL Int +newtype Lit = IntL Int deriving (Show, Read, Eq, Lift) -type Name = String +type Name = T.Text type Tag = Int data ScDef b = ScDef b [b] (Expr b) deriving (Show, Lift) +unliftScDef :: ScDef b -> Expr b +unliftScDef (ScDef _ as e) = Lam as e + data Module b = Module (Maybe (Name, [Name])) (Program b) deriving (Show, Lift) -newtype Program b = Program [ScDef b] - deriving (Show, Lift) +data Program b = Program + { _programScDefs :: [ScDef b] + , _programTypeSigs :: HashMap b Type + , _programDataTags :: HashMap b (Tag, Int) + -- ^ map constructors to their tag and arity + } + deriving (Show, Lift, Generic) + deriving (Semigroup, Monoid) + via Generically (Program b) -programScDefs :: Lens' (Program b) [ScDef b] -programScDefs = lens coerce (const coerce) +makeLenses ''Program +makeBaseFunctor ''Expr +pure [] + +-- this is a weird optic, stronger than Lens and Prism, but weaker than Iso. +programTypeSigsP :: (Hashable b) => Prism' (Program b) (HashMap b Type) +programTypeSigsP = prism + (\b -> mempty & programTypeSigs .~ b) + (Right . view programTypeSigs) + +type ExprF' = ExprF Name type Program' = Program Name type Expr' = Expr Name @@ -116,13 +169,14 @@ type Alter' = Alter Name type Binding' = Binding Name instance IsString (Expr b) where - fromString = Var + fromString = Var . fromString -instance Semigroup (Program b) where - (<>) = coerce $ (<>) @[ScDef b] - -instance Monoid (Program b) where - mempty = Program [] +instance IsString Type where + fromString "" = error "IsString Type string may not be empty" + fromString s + | isUpper c = TyCon . fromString $ s + | otherwise = TyVar . fromString $ s + where (c:_) = s ---------------------------------------------------------------------------------- @@ -155,5 +209,94 @@ instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where _lhs = lens (\ (ScDef n as _) -> (n,as)) - (\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e)) + (\ (ScDef _ _ e) (n',as') -> ScDef n' as' e) + +instance HasLHS (Binding b) (Binding b) b b where + _lhs = lens + (\ (k := _) -> k) + (\ (_ := e) k' -> k' := e) + +-------------------------------------------------------------------------------- + +-- TODO: print type sigs with corresponding scdefs +-- TODO: emit pragmas for datatags +instance (Hashable b, Pretty b) => Pretty (Program b) where + pretty p = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p + $+$ vlinesOf (programJoinedDefs . to prettyGroup) p + where + programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b)) + programJoinedDefs = folding $ \p -> + foldMapOf programTypeSigs thisTs p + `u` foldMapOf programScDefs thatSc p + where u = H.unionWith unionThese + + thisTs = ifoldMap @b @(HashMap b) + (\n t -> H.singleton n (This (n,t))) + thatSc = foldMap $ \sc -> + H.singleton (sc ^. _lhs . _1) (That sc) + + prettyGroup :: These (b, Type) (ScDef b) -> Doc + prettyGroup = bifoldr ($$) ($$) mempty . bimap prettyTySig pretty + + prettyTySig (n,t) = hsep [ttext n, "::", pretty t] + + unionThese (This a) (That b) = These a b + unionThese (That b) (This a) = These a b + unionThese (These a b) _ = These a b + + cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc + + prettyDataTag n t a = + hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"] + +instance Pretty Type where + prettyPrec _ (TyVar n) = ttext n + prettyPrec _ TyFun = "(->)" + prettyPrec _ (TyCon n) = ttext n + prettyPrec p (a :-> b) = maybeParens (p>0) $ + hsep [prettyPrec 1 a, "->", prettyPrec 0 b] + prettyPrec p (TyApp f x) = maybeParens (p>1) $ + prettyPrec 1 f <+> prettyPrec 2 x + +instance (Pretty b) => Pretty (ScDef b) where + pretty sc = hsep [name, as, "=", hang empty 1 e, ";"] + where + name = ttext $ sc ^. _lhs . _1 + as = sc & hsepOf (_lhs . _2 . each . to ttext) + e = pretty $ sc ^. _rhs + +instance (Pretty b) => Pretty (Expr b) where + prettyPrec _ (Var n) = ttext n + prettyPrec _ (Con t a) = "Pack{" <> (ttext t <+> ttext a) <> "}" + prettyPrec _ (Lam bs e) = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e] + prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs] + $+$ hsep ["in", pretty e] + where word = if r == Rec then "letrec" else "let" + prettyPrec p (App f x) = maybeParens (p>0) $ + prettyPrec 0 f <+> prettyPrec 1 x + prettyPrec _ (Lit l) = pretty l + prettyPrec p (Case e as) = maybeParens (p>0) $ + "case" <+> pretty e <+> "of" + $+$ nest 2 (explicitLayout as) + +instance (Pretty b) => Pretty (Alter b) where + pretty (Alter c as e) = + hsep [pretty c, hsep (pretty <$> as), "->", pretty e] + +instance Pretty AltCon where + pretty (AltData n) = ttext n + pretty (AltLit l) = pretty l + pretty (AltTag t) = ttext t + pretty AltDefault = "_" + +instance Pretty Lit where + pretty (IntL n) = ttext n + +instance (Pretty b) => Pretty (Binding b) where + pretty (k := v) = hsep [pretty k, "=", pretty v] + +explicitLayout :: (Pretty a) => [a] -> Doc +explicitLayout as = vcat inner <+> "}" where + inner = zipWith (<+>) delims (pretty <$> as) + delims = "{" : repeat ";" diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 5239239..71f6a7a 100644 --- a/src/Core/TH.hs +++ b/src/Core/TH.hs @@ -5,62 +5,53 @@ Description : Core quasiquoters module Core.TH ( coreExpr , coreProg - , core + , coreExprT + , coreProgT ) where ---------------------------------------------------------------------------------- import Language.Haskell.TH -import Language.Haskell.TH.Syntax hiding (Module) +import Language.Haskell.TH.Syntax hiding (Module) import Language.Haskell.TH.Quote import Control.Monad ((>=>)) +import Control.Monad.IO.Class +import Control.Arrow ((>>>)) import Compiler.RLPC import Data.Default.Class (def) +import Data.Text (Text) +import Data.Text qualified as T import Core.Parse import Core.Lex +import Core.Syntax +import Core.HindleyMilner (checkCoreProgR, checkCoreExprR) ---------------------------------------------------------------------------------- -core :: QuasiQuoter -core = QuasiQuoter - { quoteExp = qCore - , quotePat = error "core quasiquotes may only be used in expressions" - , quoteType = error "core quasiquotes may only be used in expressions" - , quoteDec = error "core quasiquotes may only be used in expressions" - } - coreProg :: QuasiQuoter -coreProg = QuasiQuoter - { quoteExp = qCoreProg - , quotePat = error "core quasiquotes may only be used in expressions" - , quoteType = error "core quasiquotes may only be used in expressions" - , quoteDec = error "core quasiquotes may only be used in expressions" - } +coreProg = mkqq $ lexCoreR >=> parseCoreProgR coreExpr :: QuasiQuoter -coreExpr = QuasiQuoter - { quoteExp = qCoreExpr +coreExpr = mkqq $ lexCoreR >=> parseCoreExprR + +-- | Type-checked @coreProg@ +coreProgT :: QuasiQuoter +coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR + +coreExprT :: QuasiQuoter +coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g + where + g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#") + , ("id", TyCon "a" :-> TyCon "a") + , ("fix", (TyCon "a" :-> TyCon "a") :-> TyCon "a") + ] + +mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter +mkqq p = QuasiQuoter + { quoteExp = mkq p , quotePat = error "core quasiquotes may only be used in expressions" , quoteType = error "core quasiquotes may only be used in expressions" , quoteDec = error "core quasiquotes may only be used in expressions" } -qCore :: String -> Q Exp -qCore s = case parse s of - Left e -> error (show e) - Right (m,ts) -> lift m - where - 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 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 def . (lexCore >=> parseCoreProg) +mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp +mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs index dd9c6ed..956a067 100644 --- a/src/Core/Utils.hs +++ b/src/Core/Utils.hs @@ -1,16 +1,10 @@ --- for recursion schemes -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} --- for recursion schemes -{-# LANGUAGE TemplateHaskell, TypeFamilies #-} - module Core.Utils - ( bindersOf - , rhssOf + ( programRhss + , programGlobals , isAtomic - , insertModule + -- , insertModule , extractProgram , freeVariables - , ExprF(..) ) where ---------------------------------------------------------------------------------- @@ -19,35 +13,32 @@ import Data.Functor.Foldable import Data.Set (Set) import Data.Set qualified as S import Core.Syntax +import Lens.Micro import GHC.Exts (IsList(..)) ---------------------------------------------------------------------------------- -bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l -bindersOf bs = fromList $ fmap f bs - where f (k := _) = k +programGlobals :: Traversal' (Program b) b +programGlobals = programScDefs . each . _lhs . _1 -rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l -rhssOf = fromList . fmap f - where f (_ := v) = v +programRhss :: Traversal' (Program b) (Expr b) +programRhss = programScDefs . each . _rhs isAtomic :: Expr b -> Bool isAtomic (Var _) = True -isAtomic (LitE _) = True +isAtomic (Lit _) = True isAtomic _ = False ---------------------------------------------------------------------------------- -- TODO: export list awareness -insertModule :: Module b -> Program b -> Program b -insertModule (Module _ m) p = p <> m +-- insertModule :: Module b -> Program b -> Program b +-- insertModule (Module _ p) = programScDefs %~ (<>m) extractProgram :: Module b -> Program b extractProgram (Module _ p) = p ---------------------------------------------------------------------------------- -makeBaseFunctor ''Expr - freeVariables :: Expr' -> Set Name freeVariables = cata go where @@ -56,8 +47,8 @@ freeVariables = cata go -- TODO: collect free vars in rhss of bs go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns where - es = rhssOf bs :: [Expr'] - ns = bindersOf bs + es = bs ^.. each . _rhs :: [Expr'] + ns = S.fromList $ bs ^.. each . _lhs -- TODO: this feels a little wrong. maybe a different scheme is -- appropriate esFree = foldMap id $ freeVariables <$> es diff --git a/src/Core2Core.hs b/src/Core2Core.hs index ed885bc..d1bcfe3 100644 --- a/src/Core2Core.hs +++ b/src/Core2Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImplicitParams #-} module Core2Core ( core2core , gmPrep @@ -14,39 +14,82 @@ import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S import Data.List +import Data.Foldable import Control.Monad.Writer -import Control.Monad.State +import Control.Monad.State.Lazy import Control.Arrow ((>>>)) +import Data.Text qualified as T +import Data.HashMap.Strict (HashMap) import Numeric (showHex) -import Lens.Micro + +import Data.Pretty +import Compiler.RLPC +-- import Lens.Micro.Platform +import Control.Lens import Core.Syntax import Core.Utils ---------------------------------------------------------------------------------- +-- | General optimisations + core2core :: Program' -> Program' core2core p = undefined +gmPrepR :: (Monad m) => Program' -> RLPCT m Program' +gmPrepR p = do + let p' = gmPrep p + addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p' + pure p' + +-- | G-machine-specific preprocessing. + gmPrep :: Program' -> Program' -gmPrep p = p' <> Program caseScs +gmPrep p = p & appFloater (floatNonStrictCases globals) + & tagData + & defineData where - rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z) - rhss = programScDefs . each . _rhs globals = p ^.. programScDefs . each . _lhs . _1 & S.fromList - -- i kinda don't like that we're calling floatNonStrictCases twice tbh - p' = p & rhss %~ fst . runFloater . floatNonStrictCases globals - caseScs = (p ^.. rhss) - <&> snd . runFloater . floatNonStrictCases globals - & mconcat +-- | Define concrete supercombinators for all datatags defined via pragmas (or +-- desugaring) + +defineData :: Program' -> Program' +defineData p = p & programScDefs <>~ defs + where + defs = p ^. programDataTags + . to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)])) + +-- | Substitute all pattern matches on named constructors for matches on tags + +tagData :: Program' -> Program' +tagData p = let ?dt = p ^. programDataTags + in p & programRhss %~ cata go where + go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr' + go (CaseF e as) = Case e (tagAlts <$> as) + go x = embed x + + tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter' + tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e) + where tag = case ?dt ^. at c of + Just (t,_) -> t + -- TODO: errorful + Nothing -> error $ "unknown constructor " <> show c + tagAlts x = x -- | Auxilary type used in @floatNonSrictCases@ type Floater = StateT [Name] (Writer [ScDef']) +appFloater :: (Expr' -> Floater Expr') -> Program' -> Program' +appFloater fl p = p & traverseOf programRhss fl + & runFloater + & \ (me,floats) -> me & programScDefs %~ (<>floats) + +-- TODO: move NameSupply from Rlp2Core into a common module to share here runFloater :: Floater a -> (a, [ScDef']) runFloater = flip evalStateT ns >>> runWriter where - ns = [ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ] + ns = [ T.pack $ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ] -- TODO: formally define a "strict context" and reference that here -- the returned ScDefs are guaranteed to be free of non-strict cases. @@ -55,7 +98,7 @@ floatNonStrictCases g = goE where goE :: Expr' -> Floater Expr' goE (Var k) = pure (Var k) - goE (LitE l) = pure (LitE l) + goE (Lit l) = pure (Lit l) goE (Case e as) = pure (Case e as) goE (Let Rec bs e) = Let Rec <$> bs' <*> goE e where bs' = travBs goE bs @@ -72,16 +115,16 @@ floatNonStrictCases g = goE altBodies = (\(Alter _ _ b) -> b) <$> as tell [sc] goE e - traverse goE altBodies + traverse_ goE altBodies pure e' goC (f :$ x) = (:$) <$> goC f <*> goC x goC (Let r bs e) = Let r <$> bs' <*> goE e where bs' = travBs goC bs - goC (LitE l) = pure (LitE l) + goC (Lit l) = pure (Lit l) goC (Var k) = pure (Var k) goC (Con t as) = pure (Con t as) - name = state (fromJust . uncons) + name = state (fromJust . Data.List.uncons) -- extract the right-hand sides of a list of bindings, traverse each -- one, and return the original list of bindings @@ -89,6 +132,7 @@ floatNonStrictCases g = goE travBs c bs = bs ^.. each . _rhs & traverse goC & const (pure bs) + -- ^ ??? what the fuck? -- when provided with a case expr, floatCase will float the case into a -- supercombinator of its free variables. the sc is returned along with an diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 2fa28de..878cab6 100644 --- a/src/Data/Heap.hs +++ b/src/Data/Heap.hs @@ -27,6 +27,7 @@ import Debug.Trace import Data.Map.Strict qualified as M import Data.List (intersect) import GHC.Stack (HasCallStack) +import Control.Lens ---------------------------------------------------------------------------------- data Heap a = Heap [Addr] (Map Addr a) @@ -34,6 +35,21 @@ data Heap a = Heap [Addr] (Map Addr a) type Addr = Int +type instance Index (Heap a) = Addr +type instance IxValue (Heap a) = a + +instance Ixed (Heap a) where + ix a k (Heap as m) = Heap as <$> M.alterF k' a m where + k' (Just v) = Just <$> k v + k' Nothing = pure Nothing + +instance At (Heap a) where + at ma k (Heap as m) = Heap as <$> M.alterF k ma m + +instance FoldableWithIndex Addr Heap where + ifoldr fi z (Heap _ m) = ifoldr fi z m + ifoldMap iam (Heap _ m) = ifoldMap iam m + instance Semigroup (Heap a) where Heap ua ma <> Heap ub mb = Heap u m where @@ -54,7 +70,7 @@ instance Foldable Heap where length (Heap _ m) = M.size m instance Traversable Heap where - traverse t (Heap u m) = Heap u <$> (traverse t m) + traverse t (Heap u m) = Heap u <$> traverse t m ---------------------------------------------------------------------------------- diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index 83958a9..77337d7 100644 --- a/src/Data/Pretty.hs +++ b/src/Data/Pretty.hs @@ -1,80 +1,65 @@ -{-# LANGUAGE OverloadedStrings #-} module Data.Pretty ( Pretty(..) - , ISeq(..) - , precPretty - , prettyPrint - , prettyShow - , iShow - , iBracket - , withPrec - , bracketPrec + , rpretty + , ttext + -- * Pretty-printing lens combinators + , hsepOf, vsepOf + , vcatOf + , vlinesOf + , module Text.PrettyPrint + , maybeParens ) where ---------------------------------------------------------------------------------- -import Data.String (IsString(..)) +import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.HughesPJ hiding ((<>)) +import Text.Printf +import Data.String (IsString(..)) +import Data.Text.Lens +import Data.Monoid +import Data.Text qualified as T +import Control.Lens ---------------------------------------------------------------------------------- class Pretty a where - pretty :: a -> ISeq - prettyPrec :: a -> Int -> ISeq + pretty :: a -> Doc + prettyPrec :: Int -> a -> Doc {-# MINIMAL pretty | prettyPrec #-} - pretty a = prettyPrec a 0 - prettyPrec a _ = iBracket (pretty a) + pretty = prettyPrec 0 + prettyPrec a _ = pretty a -precPretty :: (Pretty a) => Int -> a -> ISeq -precPretty = flip prettyPrec +rpretty :: (IsString s, Pretty a) => a -> s +rpretty = fromString . render . pretty -prettyPrint :: (Pretty a) => a -> IO () -prettyPrint = putStr . squash . pretty +instance Pretty String where + pretty = Text.PrettyPrint.text -prettyShow :: (Pretty a) => a -> String -prettyShow = squash . pretty +instance Pretty T.Text where + pretty = Text.PrettyPrint.text . view unpacked -data ISeq where - INil :: ISeq - IStr :: String -> ISeq - IAppend :: ISeq -> ISeq -> ISeq - IIndent :: ISeq -> ISeq - IBreak :: ISeq +newtype Showing a = Showing a -instance IsString ISeq where - fromString = IStr +instance (Show a) => Pretty (Showing a) where + prettyPrec p (Showing a) = fromString $ showsPrec p a "" -instance Semigroup ISeq where - (<>) = IAppend +deriving via Showing Int instance Pretty Int -instance Monoid ISeq where - mempty = INil +-------------------------------------------------------------------------------- -squash :: ISeq -> String -squash a = flatten 0 [(a,0)] +ttext :: Pretty t => t -> Doc +ttext = pretty -flatten :: Int -> [(ISeq, Int)] -> String -flatten _ [] = "" -flatten c ((INil, i) : ss) = flatten c ss -flatten c ((IStr s, i) : ss) = s ++ flatten (c + length s) ss -flatten c ((IAppend r s, i) : ss) = flatten c ((r,i) : (s,i) : ss) -flatten _ ((IBreak, i) : ss) = '\n' : replicate i ' ' ++ flatten i ss -flatten c ((IIndent s, i) : ss) = flatten c ((s,c) : ss) +hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc +hsepOf l = foldrOf l (<+>) mempty -iBracket :: ISeq -> ISeq -iBracket s = IStr "(" <> s <> IStr ")" +vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc +vsepOf l = foldrOf l ($+$) mempty -withPrec :: Int -> ISeq -> Int -> ISeq -withPrec n s p - | p > n = iBracket s - | otherwise = s +vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc +vcatOf l = foldrOf l ($$) mempty -bracketPrec :: Int -> Int -> ISeq -> ISeq -bracketPrec n p s = withPrec n s p +vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc +vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty +-- hack(?) to separate chunks with a blankline -iShow :: (Show a) => a -> ISeq -iShow = IStr . show - ----------------------------------------------------------------------------------- - -instance (Pretty a) => Pretty (Maybe a) where - prettyPrec (Just a) p = prettyPrec a p - prettyPrec Nothing p = "" diff --git a/src/GM.hs b/src/GM.hs index a29e158..c815e83 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -8,8 +8,13 @@ Description : The G-Machine module GM ( hdbgProg , evalProg + , evalProgR + , GmState(..) + , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats , Node(..) + , showState , gmEvalProg + , Stats(..) , finalStateOf , resultOf , resultOfExpr @@ -22,19 +27,37 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid (Endo(..)) import Data.Tuple (swap) import Lens.Micro +import Lens.Micro.Extras (view) import Lens.Micro.TH +import Lens.Micro.Platform (packed, unpacked) +import Lens.Micro.Platform.Internal (IsText(..)) import Text.Printf import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint.HughesPJ (maybeParens) import Data.Foldable (traverse_) import System.IO (Handle, hPutStrLn) +-- TODO: an actual output system +-- TODO: an actual output system +-- TODO: an actual output system +-- TODO: an actual output system +import System.IO.Unsafe (unsafePerformIO) import Data.String (IsString) import Data.Heap import Debug.Trace +import Compiler.RLPC import Core2Core import Core ---------------------------------------------------------------------------------- +tag_Unit_unit :: Int +tag_Unit_unit = 0 + +tag_Bool_True :: Int +tag_Bool_True = 1 + +tag_Bool_False :: Int +tag_Bool_False = 0 + {-} hdbgProg = undefined @@ -70,6 +93,7 @@ data Key = NameKey Name | ConstrKey Tag Int deriving (Show, Eq) +-- >> [ref/Instr] data Instr = Unwind | PushGlobal Name | PushConstr Tag Int @@ -84,12 +108,14 @@ data Instr = Unwind -- arith | Neg | Add | Sub | Mul | Div -- comparison - | Equals + | Equals | Lesser | GreaterEq | Pack Tag Int -- Pack Tag Arity | CaseJump [(Tag, Code)] | Split Int + | Print | Halt deriving (Show, Eq) +-- << [ref/Instr] data Node = NNum Int | NAp Addr Addr @@ -132,7 +158,7 @@ evalProg p = res <&> (,sts) resAddr = final ^. gmStack ^? _head res = resAddr >>= flip hLookup h -hdbgProg :: Program' -> Handle -> IO (Node, Stats) +hdbgProg :: Program' -> Handle -> IO GmState hdbgProg p hio = do (renderOut . showState) `traverse_` states -- TODO: i'd like the statistics to be at the top of the file, but `sts` @@ -140,7 +166,7 @@ hdbgProg p hio = do -- *can't* get partial logs in the case of a crash. this is in opposition to -- the above traversal which *will* produce partial logs. i love laziness :3 renderOut . showStats $ sts - pure (res, sts) + pure final where renderOut r = hPutStrLn hio $ render r ++ "\n" @@ -153,6 +179,21 @@ hdbgProg p hio = do [resAddr] = final ^. gmStack res = hLookupUnsafe resAddr h +evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats) +evalProgR p = do + (renderOut . showState) `traverse_` states + renderOut . showStats $ sts + pure (res, sts) + where + renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n" + states = eval . compile $ p + final = last states + + sts = final ^. gmStats + -- the address of the result should be the one and only stack entry + [resAddr] = final ^. gmStack + res = hLookupUnsafe resAddr (final ^. gmHeap) + eval :: GmState -> [GmState] eval st = st : rest where @@ -175,29 +216,55 @@ isFinal st = null $ st ^. gmCode step :: GmState -> GmState step st = case head (st ^. gmCode) of - Unwind -> unwindI + Unwind -> unwindI PushGlobal n -> pushGlobalI n PushConstr t n -> pushConstrI t n PushInt n -> pushIntI n Push n -> pushI n - MkAp -> mkApI + MkAp -> mkApI Slide n -> slideI n Pop n -> popI n Update n -> updateI n Alloc n -> allocI n - Eval -> evalI - Neg -> negI - Add -> addI - Sub -> subI - Mul -> mulI - Div -> divI - Equals -> equalsI + Eval -> evalI + Neg -> negI + Add -> addI + Sub -> subI + Mul -> mulI + Div -> divI + Equals -> equalsI + Lesser -> lesserI + GreaterEq -> greaterEqI Split n -> splitI n Pack t n -> packI t n CaseJump as -> caseJumpI as + Print -> printI Halt -> haltI where + printI :: GmState + printI = case hLookupUnsafe a h of + NNum n -> (evilTempPrinter `seq` st) + & gmCode .~ i + & gmStack .~ s + where + -- TODO: an actual output system + -- TODO: an actual output system + -- TODO: an actual output system + -- TODO: an actual output system + evilTempPrinter = unsafePerformIO (print n) + NConstr _ as -> st + & gmCode .~ i' ++ i + & gmStack .~ s' + where + i' = mconcat $ replicate n [Eval,Print] + n = length as + s' = as ++ s + where + h = st ^. gmHeap + (a:s) = st ^. gmStack + Print : i = st ^. gmCode + -- nuke the state haltI :: GmState haltI = error "halt#" @@ -281,7 +348,7 @@ step st = case head (st ^. gmCode) of m = st ^. gmEnv s = st ^. gmStack h = st ^. gmHeap - n' = show n + n' = show n ^. packed -- Core Rule 2. (no sharing) -- pushIntI :: Int -> GmState @@ -391,8 +458,10 @@ step st = case head (st ^. gmCode) of mulI = primitive2 boxInt unboxInt (*) st divI = primitive2 boxInt unboxInt div st - equalsI :: GmState + lesserI, greaterEqI, equalsI :: GmState equalsI = primitive2 boxBool unboxInt (==) st + lesserI = primitive2 boxBool unboxInt (<) st + greaterEqI = primitive2 boxBool unboxInt (>=) st splitI :: Int -> GmState splitI n = st @@ -534,12 +603,13 @@ boxBool st p = st where h = st ^. gmHeap (h',a) = alloc h (NConstr p' []) - p' = if p then 1 else 0 + p' = if p then tag_Bool_True else tag_Bool_False unboxBool :: Addr -> GmState -> Bool unboxBool a st = case hLookup a h of - Just (NConstr 1 []) -> True - Just (NConstr 0 []) -> False + Just (NConstr t []) + | t == tag_Bool_True -> True + | t == tag_Bool_False -> False Just _ -> error "unboxInt received a non-int" Nothing -> error "unboxInt received an invalid address" where h = st ^. gmHeap @@ -575,6 +645,10 @@ compiledPrims = , binop "*#" Mul , binop "/#" Div , binop "==#" Equals + , binop "<#" Lesser + , binop ">=#" GreaterEq + , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1 + , Unwind ]) ] where unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind]) @@ -582,7 +656,7 @@ compiledPrims = binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind]) buildInitialHeap :: Program' -> (GmHeap, Env) -buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs +buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compiledScs where compiledScs = fmap compileSc ss <> compiledPrims @@ -612,12 +686,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs | k `elem` domain = [Push n] | otherwise = [PushGlobal k] where - n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g + n = fromMaybe err $ lookupN k g + err = error $ "undeclared var: " <> (k ^. unpacked) domain = f `mapMaybe` g f (NameKey n, _) = Just n f _ = Nothing - compileC _ (LitE l) = compileCL l + compileC _ (Lit l) = compileCL l -- >> [ref/compileC] compileC g (App f x) = compileC g x @@ -657,33 +732,32 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileC _ (Con t n) = [PushConstr t n] compileC _ (Case _ _) = - error "case expressions may not appear in non-strict contexts :/" + error "GM compiler found a non-strict case expression, which should\ + \ have been floated by Core2Core.gmPrep. This is a bug!" compileC _ _ = error "yet to be implemented!" - compileCL :: Literal -> Code + compileCL :: Lit -> Code compileCL (IntL n) = [PushInt n] - compileEL :: Literal -> Code + compileEL :: Lit -> Code compileEL (IntL n) = [PushInt n] -- compile an expression in a strict context such that a pointer to the -- expression is left on top of the stack in WHNF compileE :: Env -> Expr' -> Code - compileE _ (LitE l) = compileEL l + compileE _ (Lit l) = compileEL l compileE g (Let NonRec bs e) = -- we use compileE instead of compileC mconcat binders <> compileE g' e <> [Slide d] where d = length bs - (g',binders) = mapAccumL compileBinder (argOffset d g) addressed - -- kinda gross. revisit this - addressed = bs `zip` reverse [0 .. d-1] + (g',binders) = mapAccumL compileBinder g bs - compileBinder :: Env -> (Binding', Int) -> (Env, Code) - compileBinder m (k := v, a) = (m',c) + compileBinder :: Env -> Binding' -> (Env, Code) + compileBinder m (k := v) = (m',c) where - m' = (NameKey k, a) : m + m' = (NameKey k, 0) : argOffset 1 m -- make note that we use m rather than m'! c = compileC m v @@ -711,21 +785,27 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul a b compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b + compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b + compileE g (">=#" :$ a :$ b) = inlineOp2 g GreaterEq a b compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] compileE g e = compileC g e ++ [Eval] compileD :: Env -> [Alter'] -> [(Tag, Code)] - compileD g as = fmap (compileA g) as + compileD g = fmap (compileA g) compileA :: Env -> Alter' -> (Tag, Code) - compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n]) + compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n]) where n = length as binds = (NameKey <$> as) `zip` [0..] g' = binds ++ argOffset n g c = compileE g' e + compileA _ (Alter _ as e) = error "GM.compileA found an untagged\ + \ constructor, which should have\ + \ been handled by Core2Core.gmPrep.\ + \ This is a bug!" inlineOp1 :: Env -> Instr -> Expr' -> Code inlineOp1 g i a = compileE g a <> [i] @@ -738,8 +818,8 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs argOffset :: Int -> Env -> Env argOffset n = each . _2 %~ (+n) -idPack :: Tag -> Int -> String -idPack t n = printf "Pack{%d %d}" t n +showCon :: (IsText a) => Tag -> Int -> a +showCon t n = printf "Pack{%d %d}" t n ^. packed ---------------------------------------------------------------------------------- @@ -855,12 +935,12 @@ showNodeAt = showNodeAtP 0 showNodeAtP :: Int -> GmState -> Addr -> Doc showNodeAtP p st a = case hLookup a h of Just (NNum n) -> int n <> "#" - Just (NGlobal _ _) -> text name + Just (NGlobal _ _) -> textt name where g = st ^. gmEnv name = case lookup a (swap <$> g) of Just (NameKey n) -> n - Just (ConstrKey t n) -> idPack t n + Just (ConstrKey t n) -> showCon t n _ -> errTxtInvalidAddress -- TODO: left-associativity Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f @@ -877,7 +957,7 @@ showNodeAtP p st a = case hLookup a h of pprec = maybeParens (p > 0) showSc :: GmState -> (Name, Addr) -> Doc -showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon +showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon $$ code where code = case hLookup a (st ^. gmHeap) of @@ -900,6 +980,9 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts showInstr i = text $ show i +textt :: (IsText a) => a -> Doc +textt t = t ^. unpacked & text + ---------------------------------------------------------------------------------- lookupN :: Name -> Env -> Maybe Addr @@ -975,7 +1058,8 @@ resultOf p = do h = st ^. gmHeap resultOfExpr :: Expr' -> Maybe Node -resultOfExpr e = resultOf $ Program - [ ScDef "main" [] e - ] +resultOfExpr e = resultOf $ + mempty & programScDefs .~ + [ ScDef "main" [] e + ] diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs deleted file mode 100644 index 6efdc4e..0000000 --- a/src/RLP/Syntax.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module RLP.Syntax - ( RlpExpr - ) - where ----------------------------------------------------------------------------------- -import Data.Text (Text) -import Lens.Micro -import Core (HasRHS(..), HasLHS(..)) ----------------------------------------------------------------------------------- - -newtype RlpProgram b = RlpProgram [Decl b] - -data Decl b = InfixD InfixAssoc Int VarId - | FunD VarId [Pat b] (RlpExpr b) - | DataD ConId [ConId] [ConAlt] - -data ConAlt = ConAlt ConId [ConId] - -data InfixAssoc = Assoc | AssocL | AssocR - -data RlpExpr b = LetE [Bind b] (RlpExpr b) - | VarE VarId - | ConE ConId - | LamE [Pat b] (RlpExpr b) - | CaseE (RlpExpr b) [Alt b] - | IfE (RlpExpr b) (RlpExpr b) (RlpExpr b) - | AppE (RlpExpr b) (RlpExpr b) - | LitE (Lit b) - --- do we want guards? -data Alt b = AltA (Pat b) (RlpExpr b) - -data Bind b = PatB (Pat b) (RlpExpr b) - | FunB VarId [Pat b] (RlpExpr b) - -data VarId = NameVar Text - | SymVar Text - -data ConId = NameCon Text - | SymCon Text - -data Pat b = VarP VarId - | LitP (Lit b) - | ConP ConId [Pat b] - -data Lit b = IntL Int - | CharL Char - | ListL [RlpExpr b] - --- instance HasLHS Alt Alt Pat Pat where --- _lhs = lens --- (\ (AltA p _) -> p) --- (\ (AltA _ e) p' -> AltA p' e) - --- instance HasRHS Alt Alt RlpExpr RlpExpr where --- _rhs = lens --- (\ (AltA _ e) -> e) --- (\ (AltA p _) e' -> AltA p e') diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x new file mode 100644 index 0000000..d046499 --- /dev/null +++ b/src/Rlp/Lex.x @@ -0,0 +1,378 @@ +{ +{-# LANGUAGE ViewPatterns, LambdaCase #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Rlp.Lex + ( P(..) + , RlpToken(..) + , Located(..) + , lexToken + , lexStream + , lexDebug + , lexCont + , popLexState + , programInitState + , runP' + ) + where +import Codec.Binary.UTF8.String (encodeChar) +import Control.Monad +import Control.Monad.Errorful +import Core.Syntax (Name) +import Data.Functor.Identity +import Data.Char (digitToInt) +import Data.Monoid (First) +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word +import Data.Default +import Lens.Micro.Mtl +import Lens.Micro + +import Debug.Trace +import Rlp.Parse.Types +} + +$whitechar = [ \t\n\r\f\v] + +$nl = [\n\r] +$white_no_nl = $white # $nl + +$lower = [a-z \_] +$upper = [A-Z] +$alpha = [$lower $upper] +$digit = 0-9 + +$special = [\(\)\,\;\[\]\{\}] +$namechar = [$alpha $digit \' \#] +$asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] + +@decimal = $digit+ + +@varname = $lower $namechar* +@conname = $upper $namechar* +@consym = \: $asciisym* +@varsym = $asciisym+ + +@reservedname = + case|data|do|import|in|let|letrec|module|of|where + |infixr|infixl|infix + +@reservedop = + "=" | \\ | "->" | "|" | "::" + +rlp :- + +-- everywhere: skip whitespace +$white_no_nl+ ; + +-- everywhere: skip comments +-- TODO: don't treat operators like (-->) as comments +"--".* ; + +-- we are indentation-sensitive! do not skip NLs!. upon encountering a newline, +-- we check indentation and potentially insert extra tokens. search this file +-- for the definition of `doBol` +<0> \n { beginPush bol } + + +{ + +} + +-- layout keywords +<0> +{ + "let" { constToken TokenLet `thenBeginPush` layout_let } + "letrec" { constToken TokenLetrec `thenBeginPush` layout_let } + "of" { constToken TokenOf `thenBeginPush` layout_of } +} + +-- scan various identifiers and reserved words. order is important here! +<0> +{ + @reservedname { tokenWith lexReservedName } + @conname { tokenWith TokenConName } + @varname { tokenWith TokenVarName } + @reservedop { tokenWith lexReservedOp } + @consym { tokenWith TokenConSym } + @varsym { tokenWith TokenVarSym } +} + +-- literals -- currently this is just unsigned integer literals +<0> +{ + @decimal { tokenWith (TokenLitInt . readInt) } +} + +-- control characters +<0> +{ + "(" { constToken TokenLParen } + ")" { constToken TokenRParen } + "{" { explicitLBrace } + "}" { explicitRBrace } + ";" { constToken TokenSemicolon } +} + +-- consume all whitespace leaving us at the beginning of the next non-empty +-- line. we then compare the indentation of that line to the enclosing layout +-- context and proceed accordingly + +{ + $whitechar ; + \n ; + () { doBol } +} + + +{ + \n ; + "{" { explicitLBrace `thenDo` popLexState } +} + + +{ + \n { beginPush bol } + "{" { explicitLBrace `thenDo` popLexState } +} + + +{ + "in" { constToken TokenIn `thenDo` (popLexState *> popLayout) } +} + + +{ + () { doLayout } +} + +{ + +lexReservedName :: Text -> RlpToken +lexReservedName = \case + "data" -> TokenData + "case" -> TokenCase + "of" -> TokenOf + "let" -> TokenLet + "letrec" -> TokenLetrec + "in" -> TokenIn + "infix" -> TokenInfix + "infixl" -> TokenInfixL + "infixr" -> TokenInfixR + s -> error (show s) + +lexReservedOp :: Text -> RlpToken +lexReservedOp = \case + "=" -> TokenEquals + "::" -> TokenHasType + "|" -> TokenPipe + "->" -> TokenArrow + s -> error (show s) + +-- | @andBegin@, with the subtle difference that the start code is set +-- /after/ the action +thenBegin :: LexerAction a -> Int -> LexerAction a +thenBegin act c inp l = do + a <- act inp l + psLexState . _head .= c + pure a + +thenBeginPush :: LexerAction a -> Int -> LexerAction a +thenBeginPush act c inp l = do + a <- act inp l + pushLexState c + pure a + +andBegin :: LexerAction a -> Int -> LexerAction a +andBegin act c inp l = do + psLexState . _head .= c + act inp l + +beginPush :: Int -> LexerAction (Located RlpToken) +beginPush n _ _ = pushLexState n >> lexToken + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte inp = case inp ^. aiBytes of + [] -> do + (c,t) <- T.uncons (inp ^. aiSource) + let (b:bs) = encodeChar c + -- tail the source + inp' = inp & aiSource .~ t + -- record the excess bytes for successive calls + & aiBytes .~ bs + -- report the previous char + & aiPrevChar .~ c + -- update the position + & aiPos %~ \ (ln,col,a) -> + if c == '\n' + then (ln+1, 1, a+1) + else (ln, col+1, a+1) + pure (b, inp') + + _ -> Just (head bs, inp') + where + (bs, inp') = inp & aiBytes <<%~ drop 1 + +getInput :: P AlexInput +getInput = use psInput + +getLexState :: P Int +getLexState = use (psLexState . singular _head) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar = view aiPrevChar + +pushLexState :: Int -> P () +pushLexState n = psLexState %= (n:) + +readInt :: Text -> Int +readInt = T.foldl f 0 where + f n c = 10*n + digitToInt c + +constToken :: RlpToken -> LexerAction (Located RlpToken) +constToken t inp l = do + pos <- use (psInput . aiPos) + pure (Located (spanFromPos pos l) t) + +tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken) +tokenWith tf inp l = do + pos <- getPos + let t = tf (T.take l $ inp ^. aiSource) + pure (Located (spanFromPos pos l) t) + +getPos :: P Position +getPos = use (psInput . aiPos) + +alexEOF :: P (Located RlpToken) +alexEOF = do + inp <- getInput + pos <- getPos + pure (Located (spanFromPos pos 0) TokenEOF) + +runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) +runP' p s = runP p st where + st = initParseState [layout_top,0] s + +lexToken :: P (Located RlpToken) +lexToken = do + inp <- getInput + c <- getLexState + st <- use id + -- traceM $ "st: " <> show st + case alexScan inp c of + AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF + AlexSkip inp' l -> do + psInput .= inp' + lexToken + AlexToken inp' l act -> do + psInput .= inp' + act inp l + AlexError inp' -> addFatalHere 1 RlpParErrLexical + +lexCont :: (Located RlpToken -> P a) -> P a +lexCont = (lexToken >>=) + +lexStream :: P [RlpToken] +lexStream = do + t <- lexToken + case t of + Located _ TokenEOF -> pure [TokenEOF] + Located _ t -> (t:) <$> lexStream + +lexDebug :: (Located RlpToken -> P a) -> P a +lexDebug k = do + t <- lexToken + traceM $ "token: " <> show t + k t + +lexTest :: Text -> Maybe [RlpToken] +lexTest s = runP' lexStream s ^. _3 + +indentLevel :: P Int +indentLevel = do + pos <- use (psInput . aiPos) + pure (pos ^. _2) + +insertToken :: RlpToken -> P (Located RlpToken) +insertToken t = do + pos <- use (psInput . aiPos) + pure (Located (spanFromPos pos 0) t) + +popLayout :: P Layout +popLayout = do + -- traceM "pop layout" + ctx <- preuse (psLayoutStack . _head) + psLayoutStack %= (drop 1) + case ctx of + Just l -> pure l + Nothing -> error "popLayout: layout stack empty! this is a bug." + +pushLayout :: Layout -> P () +pushLayout l = do + -- traceM "push layout" + psLayoutStack %= (l:) + +popLexState :: P () +popLexState = do + psLexState %= tail + +insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken) +insertSemicolon = {- traceM "inserting semi" >> -} insertToken TokenSemicolonV +insertLBrace = {- traceM "inserting lbrace" >> -} insertToken TokenLBraceV +insertRBrace = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV + +cmpLayout :: P Ordering +cmpLayout = do + i <- indentLevel + ctx <- preuse (psLayoutStack . _head) + case ctx of + Just (Implicit n) -> pure (i `compare` n) + _ -> pure GT + +doBol :: LexerAction (Located RlpToken) +doBol inp l = do + off <- cmpLayout + i <- indentLevel + -- traceM $ "i: " <> show i + -- important that we pop the lex state lest we find our lexer diverging + case off of + -- the line is aligned with the previous. it therefore belongs to the + -- same list + EQ -> popLexState *> insertSemicolon + -- the line is indented further than the previous, so we assume it is a + -- line continuation. ignore it and move on! + GT -> popLexState *> lexToken + -- the line is indented less than the previous, pop the layout stack and + -- insert a closing brace. make VERY good note of the fact that we do not + -- pop the lex state! this means doBol is called until indentation is EQ + -- GT. so if multiple layouts are closed at once, this catches that. + LT -> popLayout >> insertRBrace + +thenDo :: LexerAction a -> P b -> LexerAction a +thenDo act p inp l = act inp l <* p + +explicitLBrace :: LexerAction (Located RlpToken) +explicitLBrace inp l = do + pushLayout Explicit + constToken TokenLBrace inp l + +explicitRBrace :: LexerAction (Located RlpToken) +explicitRBrace inp l = do + popLayout + constToken TokenRBrace inp l + +doLayout :: LexerAction (Located RlpToken) +doLayout _ _ = do + i <- indentLevel + -- traceM $ "doLayout: i: " <> show i + pushLayout (Implicit i) + popLexState + insertLBrace + +programInitState :: Text -> ParseState +programInitState = initParseState [layout_top,0] + +} + diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y new file mode 100644 index 0000000..4b86aea --- /dev/null +++ b/src/Rlp/Parse.y @@ -0,0 +1,312 @@ +{ +{-# LANGUAGE LambdaCase, ViewPatterns #-} +module Rlp.Parse + ( parseRlpProg + , parseRlpProgR + , parseRlpExpr + , parseRlpExprR + ) + where +import Compiler.RlpcError +import Compiler.RLPC +import Rlp.Lex +import Rlp.Syntax +import Rlp.Parse.Types +import Rlp.Parse.Associate +import Lens.Micro.Platform +import Data.List.Extra +import Data.Fix +import Data.Functor.Const +import Data.Functor.Apply +import Data.Functor.Bind +import Control.Comonad +import Data.Functor +import Data.Semigroup.Traversable +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void +import Compiler.Types +} + +%name parseRlpProg StandaloneProgram +%name parseRlpExpr StandaloneExpr + +%monad { P } +%lexer { lexCont } { Located _ TokenEOF } +%error { parseError } +%errorhandlertype explist +%tokentype { Located RlpToken } + +%token + varname { Located _ (TokenVarName _) } + conname { Located _ (TokenConName _) } + consym { Located _ (TokenConSym _) } + varsym { Located _ (TokenVarSym _) } + data { Located _ TokenData } + case { Located _ TokenCase } + of { Located _ TokenOf } + litint { Located _ (TokenLitInt _) } + '=' { Located _ TokenEquals } + '|' { Located _ TokenPipe } + '::' { Located _ TokenHasType } + ';' { Located _ TokenSemicolon } + '(' { Located _ TokenLParen } + ')' { Located _ TokenRParen } + '->' { Located _ TokenArrow } + vsemi { Located _ TokenSemicolonV } + '{' { Located _ TokenLBrace } + '}' { Located _ TokenRBrace } + vlbrace { Located _ TokenLBraceV } + vrbrace { Located _ TokenRBraceV } + infixl { Located _ TokenInfixL } + infixr { Located _ TokenInfixR } + infix { Located _ TokenInfix } + let { Located _ TokenLet } + letrec { Located _ TokenLetrec } + in { Located _ TokenIn } + +%nonassoc '=' +%right '->' +%right in + +%% + +StandaloneProgram :: { RlpProgram RlpcPs } +StandaloneProgram : '{' Decls '}' {% mkProgram $2 } + | VL DeclsV VR {% mkProgram $2 } + +StandaloneExpr :: { RlpExpr RlpcPs } + : VL Expr VR { extract $2 } + +VL :: { () } +VL : vlbrace { () } + +VR :: { () } +VR : vrbrace { () } + | error { () } + +Decls :: { [Decl' RlpcPs] } +Decls : Decl ';' Decls { $1 : $3 } + | Decl ';' { [$1] } + | Decl { [$1] } + +DeclsV :: { [Decl' RlpcPs] } +DeclsV : Decl VS DeclsV { $1 : $3 } + | Decl VS { [$1] } + | Decl { [$1] } + +VS :: { Located RlpToken } +VS : ';' { $1 } + | vsemi { $1 } + +Decl :: { Decl' RlpcPs } + : FunDecl { $1 } + | TySigDecl { $1 } + | DataDecl { $1 } + | InfixDecl { $1 } + +TySigDecl :: { Decl' RlpcPs } + : Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 } + +InfixDecl :: { Decl' RlpcPs } + : InfixWord litint InfixOp { $1 =>> \w -> + InfixD (extract $1) (extractInt $ extract $2) + (extract $3) } + +InfixWord :: { Located Assoc } + : infixl { $1 \$> InfixL } + | infixr { $1 \$> InfixR } + | infix { $1 \$> Infix } + +DataDecl :: { Decl' RlpcPs } + : data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 } + +TyParams :: { [PsName] } + : {- epsilon -} { [] } + | TyParams varname { $1 `snoc` (extractName . extract $ $2) } + +DataCons :: { [ConAlt RlpcPs] } + : DataCons '|' DataCon { $1 `snoc` $3 } + | DataCon { [$1] } + +DataCon :: { ConAlt RlpcPs } + : Con Type1s { ConAlt (extract $1) $2 } + +Type1s :: { [RlpType' RlpcPs] } + : {- epsilon -} { [] } + | Type1s Type1 { $1 `snoc` $2 } + +Type1 :: { RlpType' RlpcPs } + : '(' Type ')' { $2 } + | conname { fmap ConT (mkPsName $1) } + | varname { fmap VarT (mkPsName $1) } + +Type :: { RlpType' RlpcPs } + : Type '->' Type { FunT <<~ $1 <~> $3 } + | TypeApp { $1 } + +TypeApp :: { RlpType' RlpcPs } + : Type1 { $1 } + | TypeApp Type1 { AppT <<~ $1 <~> $2 } + +FunDecl :: { Decl' RlpcPs } +FunDecl : Var Params '=' Expr { $4 =>> \e -> + FunD (extract $1) $2 e Nothing } + +Params :: { [Pat' RlpcPs] } +Params : {- epsilon -} { [] } + | Params Pat1 { $1 `snoc` $2 } + +Pat :: { Pat' RlpcPs } + : Con Pat1s { $1 =>> \cn -> + ConP (extract $1) $2 } + | Pat1 { $1 } + +Pat1s :: { [Pat' RlpcPs] } + : Pat1s Pat1 { $1 `snoc` $2 } + | Pat1 { [$1] } + +Pat1 :: { Pat' RlpcPs } + : Con { fmap (`ConP` []) $1 } + | Var { fmap VarP $1 } + | Lit { LitP <<= $1 } + | '(' Pat ')' { $1 .> $2 <. $3 } + +Expr :: { RlpExpr' RlpcPs } + -- infixities delayed till next release :( + -- : Expr1 InfixOp Expr { $2 =>> \o -> + -- OAppE (extract o) $1 $3 } + : TempInfixExpr { $1 } + | LetExpr { $1 } + | CaseExpr { $1 } + | AppExpr { $1 } + +TempInfixExpr :: { RlpExpr' RlpcPs } +TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 } + | Expr1 InfixOp Expr1 { $2 =>> \o -> + OAppE (extract o) $1 $3 } + +AppExpr :: { RlpExpr' RlpcPs } + : Expr1 { $1 } + | AppExpr Expr1 { AppE <<~ $1 <~> $2 } + +LetExpr :: { RlpExpr' RlpcPs } + : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } + | letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 } + +CaseExpr :: { RlpExpr' RlpcPs } + : case Expr of layout0(CaseAlt) + { CaseE <<~ $2 <#> $4 } + +-- TODO: where-binds +CaseAlt :: { (Alt RlpcPs, Where RlpcPs) } + : Alt { ($1, []) } + +Alt :: { Alt RlpcPs } + : Pat '->' Expr { AltA $1 $3 } + +-- layout0(p : β) :: [β] +layout0(p) : '{' layout_list0(';',p) '}' { $2 } + | VL layout_list0(VS,p) VR { $2 } + +-- layout_list0(sep : α, p : β) :: [β] +layout_list0(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } + | {- epsilon -} { [] } + +-- layout1(p : β) :: [β] +layout1(p) : '{' layout_list1(';',p) '}' { $2 } + | VL layout_list1(VS,p) VR { $2 } + +-- layout_list1(sep : α, p : β) :: [β] +layout_list1(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } + +Binding :: { Binding' RlpcPs } + : Pat '=' Expr { PatB <<~ $1 <~> $3 } + +Expr1 :: { RlpExpr' RlpcPs } + : '(' Expr ')' { $1 .> $2 <. $3 } + | Lit { fmap LitE $1 } + | Var { fmap VarE $1 } + | Con { fmap VarE $1 } + +InfixOp :: { Located PsName } + : consym { mkPsName $1 } + | varsym { mkPsName $1 } + +-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) +Lit :: { Lit' RlpcPs } + : litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) } + +Var :: { Located PsName } +Var : varname { mkPsName $1 } + | varsym { mkPsName $1 } + +Con :: { Located PsName } + : conname { mkPsName $1 } + +{ + +parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs) +parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st + where + st = programInitState s + +parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs) +parseRlpProgR s = do + a <- liftErrorful $ pToErrorful parseRlpProg st + addDebugMsg @_ @String "dump-parsed" $ show a + pure a + where + st = programInitState s + +mkPsName :: Located RlpToken -> Located PsName +mkPsName = fmap extractName + +extractName :: RlpToken -> PsName +extractName = \case + TokenVarName n -> n + TokenConName n -> n + TokenConSym n -> n + TokenVarSym n -> n + _ -> error "mkPsName: not an identifier" + +extractInt :: RlpToken -> Int +extractInt (TokenLitInt n) = n +extractInt _ = error "extractInt: ugh" + +mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs) +mkProgram ds = do + pt <- use psOpTable + pure $ RlpProgram (associate pt <$> ds) + +parseError :: (Located RlpToken, [String]) -> P a +parseError ((Located ss t), exp) = addFatal $ + errorMsg ss (RlpParErrUnexpectedToken t exp) + +mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs) +mkInfixD a p n = do + let opl :: Lens' ParseState (Maybe OpInfo) + opl = psOpTable . at n + opl <~ (use opl >>= \case + Just o -> addWoundHere l e >> pure (Just o) where + e = RlpParErrDuplicateInfixD n + l = T.length n + Nothing -> pure (Just (a,p)) + ) + pos <- use (psInput . aiPos) + pure $ Located (spanFromPos pos 0) (InfixD a p n) + +intOfToken :: Located RlpToken -> Int +intOfToken (Located _ (TokenLitInt n)) = n + +tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a +tempInfixExprErr (Located a _) (Located b _) = + addFatal $ errorMsg (a <> b) $ RlpParErrOther + [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :(" + , "In the mean time, don't mix any infix operators." + ] + +} + diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs new file mode 100644 index 0000000..6757705 --- /dev/null +++ b/src/Rlp/Parse/Associate.hs @@ -0,0 +1,37 @@ +module Rlp.Parse.Associate + {-# WARNING "unimplemented" #-} + ( associate + ) + where +-------------------------------------------------------------------------------- +import Data.HashMap.Strict qualified as H +import Data.Functor.Foldable +import Data.Functor.Foldable.TH +import Data.Functor.Const +import Data.Functor +import Data.Text qualified as T +import Text.Printf +import Lens.Micro +import Rlp.Parse.Types +import Rlp.Syntax +-------------------------------------------------------------------------------- + +associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs +associate _ p = p + +{-# WARNING associate "unimplemented" #-} + +examplePrecTable :: OpTable +examplePrecTable = H.fromList + [ ("+", (InfixL,6)) + , ("*", (InfixL,7)) + , ("^", (InfixR,8)) + , (".", (InfixR,7)) + , ("~", (Infix, 9)) + , ("=", (Infix, 4)) + , ("&&", (Infix, 3)) + , ("||", (Infix, 2)) + , ("$", (InfixR,0)) + , ("&", (InfixL,0)) + ] + diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs new file mode 100644 index 0000000..1f71d2b --- /dev/null +++ b/src/Rlp/Parse/Types.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +module Rlp.Parse.Types + ( + -- * Trees That Grow + RlpcPs + + -- * Parser monad and state + , P(..), ParseState(..), Layout(..), OpTable, OpInfo + , initParseState, initAlexInput + , pToErrorful + -- ** Lenses + , psLayoutStack, psLexState, psInput, psOpTable + + -- * Other parser types + , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction + , Located(..), PsName + -- ** Lenses + , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn + + , (<<~), (<~>) + + -- * Error handling + , MsgEnvelope(..), RlpcError(..), RlpParseError(..) + , addFatal, addWound, addFatalHere, addWoundHere + ) + where +-------------------------------------------------------------------------------- +import Core.Syntax (Name) +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Errorful +import Control.Comonad (extract) +import Compiler.RlpcError +import Language.Haskell.TH.Syntax (Lift) +import Data.Text (Text) +import Data.Maybe +import Data.Fix +import Data.Functor.Foldable +import Data.Functor.Const +import Data.Functor.Classes +import Data.HashMap.Strict qualified as H +import Data.Void +import Data.Word (Word8) +import Data.Text qualified as T +import Lens.Micro.TH +import Lens.Micro +import Rlp.Syntax +import Compiler.Types +-------------------------------------------------------------------------------- + +-- | Phantom type identifying rlpc's parser phase + +data RlpcPs + +type instance XRec RlpcPs a = Located a +type instance IdP RlpcPs = PsName + +type instance XFunD RlpcPs = () +type instance XDataD RlpcPs = () +type instance XInfixD RlpcPs = () +type instance XTySigD RlpcPs = () +type instance XXDeclD RlpcPs = () + +type instance XLetE RlpcPs = () +type instance XLetrecE RlpcPs = () +type instance XVarE RlpcPs = () +type instance XLamE RlpcPs = () +type instance XCaseE RlpcPs = () +type instance XIfE RlpcPs = () +type instance XAppE RlpcPs = () +type instance XLitE RlpcPs = () +type instance XParE RlpcPs = () +type instance XOAppE RlpcPs = () +type instance XXRlpExprE RlpcPs = () + +type PsName = Text + +instance MapXRec RlpcPs where + mapXRec = fmap + +instance UnXRec RlpcPs where + unXRec = extract + +-------------------------------------------------------------------------------- + +spanFromPos :: Position -> Int -> SrcSpan +spanFromPos (l,c,a) s = SrcSpan l c a s + +{-# INLINE spanFromPos #-} + +type LexerAction a = AlexInput -> Int -> P a + +data AlexInput = AlexInput + { _aiPrevChar :: Char + , _aiSource :: Text + , _aiBytes :: [Word8] + , _aiPos :: Position + } + deriving Show + +type Position = + ( Int -- ^ line + , Int -- ^ column + , Int -- ^ Absolutely + ) + +posLine :: Lens' Position Int +posLine = _1 + +posColumn :: Lens' Position Int +posColumn = _2 + +posAbsolute :: Lens' Position Int +posAbsolute = _3 + +data RlpToken + -- literals + = TokenLitInt Int + -- identifiers + | TokenVarName Name + | TokenConName Name + | TokenVarSym Name + | TokenConSym Name + -- reserved words + | TokenData + | TokenCase + | TokenOf + | TokenLet + | TokenLetrec + | TokenIn + | TokenInfixL + | TokenInfixR + | TokenInfix + -- reserved ops + | TokenArrow + | TokenPipe + | TokenHasType + | TokenLambda + | TokenEquals + -- control symbols + | TokenSemicolon + | TokenLBrace + | TokenRBrace + | TokenLParen + | TokenRParen + -- 'virtual' control symbols, inserted by the lexer without any correlation + -- to a specific part of the input + | TokenSemicolonV + | TokenLBraceV + | TokenRBraceV + | TokenEOF + deriving (Show) + +newtype P a = P { + runP :: ParseState + -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) + } + deriving (Functor) + +pToErrorful :: (Applicative m) + => P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a +pToErrorful p st = ErrorfulT $ pure (ma,es) where + (_,es,ma) = runP p st + +instance Applicative P where + pure a = P $ \st -> (st, [], pure a) + liftA2 = liftM2 + +instance Monad P where + p >>= k = P $ \st -> + let (st',es,ma) = runP p st + in case ma of + Just a -> runP (k a) st' + & _2 %~ (es<>) + Nothing -> (st',es,Nothing) + + {-# INLINE (>>=) #-} + +instance MonadState ParseState P where + state f = P $ \st -> + let (a,st') = f st + in (st', [], Just a) + +instance MonadErrorful (MsgEnvelope RlpParseError) P where + addWound e = P $ \st -> (st, [e], Just ()) + addFatal e = P $ \st -> (st, [e], Nothing) + +data ParseState = ParseState + { _psLayoutStack :: [Layout] + , _psLexState :: [Int] + , _psInput :: AlexInput + , _psOpTable :: OpTable + } + deriving Show + +data Layout = Explicit + | Implicit Int + deriving (Show, Eq) + +type OpTable = H.HashMap Name OpInfo +type OpInfo = (Assoc, Int) + +data RlpParseError = RlpParErrOutOfBoundsPrecedence Int + | RlpParErrDuplicateInfixD Name + | RlpParErrLexical + | RlpParErrUnexpectedToken RlpToken [String] + | RlpParErrOther [Text] + deriving (Show) + +instance IsRlpcError RlpParseError where + liftRlpcError = \case + RlpParErrOutOfBoundsPrecedence n -> + Text [ "Illegal precedence in infixity declaration" + , "rl' currently only allows precedences between 0 and 9." + ] + RlpParErrDuplicateInfixD s -> + Text [ "Conflicting infixity declarations for operator " + <> tshow s + ] + RlpParErrLexical -> + Text [ "Unknown lexical error :(" ] + RlpParErrUnexpectedToken t exp -> + Text [ "Unexpected token " <> tshow t + , "Expected: " <> tshow exp + ] + RlpParErrOther ts -> + Text ts + where + tshow :: (Show a) => a -> T.Text + tshow = T.pack . show + +---------------------------------------------------------------------------------- + +makeLenses ''AlexInput +makeLenses ''ParseState + +addWoundHere :: Int -> RlpParseError -> P () +addWoundHere l e = P $ \st -> + let e' = MsgEnvelope + { _msgSpan = let pos = psInput . aiPos + in SrcSpan (st ^. pos . posLine) + (st ^. pos . posColumn) + (st ^. pos . posAbsolute) + l + , _msgDiagnostic = e + , _msgSeverity = SevError + } + in (st, [e'], Just ()) + +addFatalHere :: Int -> RlpParseError -> P a +addFatalHere l e = P $ \st -> + let e' = MsgEnvelope + { _msgSpan = let pos = psInput . aiPos + in SrcSpan (st ^. pos . posLine) + (st ^. pos . posColumn) + (st ^. pos . posAbsolute) + l + , _msgDiagnostic = e + , _msgSeverity = SevError + } + in (st, [e'], Nothing) + +initParseState :: [Int] -> Text -> ParseState +initParseState ls s = ParseState + { _psLayoutStack = [] + -- IMPORTANT: the initial state is `bol` to begin the top-level layout, + -- which then returns to state 0 which continues the normal lexing process. + , _psLexState = ls + , _psInput = initAlexInput s + , _psOpTable = mempty + } + +initAlexInput :: Text -> AlexInput +initAlexInput s = AlexInput + { _aiPrevChar = '\0' + , _aiSource = s + , _aiBytes = [] + , _aiPos = (1,1,0) + } + +-------------------------------------------------------------------------------- + +deriving instance Lift (RlpProgram RlpcPs) +deriving instance Lift (Decl RlpcPs) +deriving instance Lift (Pat RlpcPs) +deriving instance Lift (Lit RlpcPs) +deriving instance Lift (RlpExpr RlpcPs) +deriving instance Lift (Binding RlpcPs) +deriving instance Lift (RlpType RlpcPs) +deriving instance Lift (Alt RlpcPs) +deriving instance Lift (ConAlt RlpcPs) + diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs new file mode 100644 index 0000000..8b49edc --- /dev/null +++ b/src/Rlp/Syntax.hs @@ -0,0 +1,363 @@ +-- recursion-schemes +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable + , TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} +module Rlp.Syntax + ( + -- * AST + RlpProgram(..) + , progDecls + , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..) + , Pat(..), Pat' + , Alt(..), Where + , Assoc(..) + , Lit(..), Lit' + , RlpType(..), RlpType' + , ConAlt(..) + , Binding(..), Binding' + + , _PatB, _FunB + , _VarP, _LitP, _ConP + + -- * Trees That Grow boilerplate + -- ** Extension points + , IdP, IdP', XRec, UnXRec(..), MapXRec(..) + -- *** Decl + , XFunD, XTySigD, XInfixD, XDataD, XXDeclD + -- *** RlpExpr + , XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE + , XParE, XOAppE, XXRlpExprE + -- ** Pattern synonyms + -- *** Decl + , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD + , pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD'' + -- *** RlpExpr + , pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE + , pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE + , pattern XRlpExprE + -- *** RlpType + , pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT'' + , pattern ConT'' + -- *** Pat + , pattern VarP'', pattern LitP'', pattern ConP'' + -- *** Binding + , pattern PatB'' + ) + where +---------------------------------------------------------------------------------- +import Data.Text (Text) +import Data.Text qualified as T +import Data.String (IsString(..)) +import Data.Functor.Foldable +import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Kind (Type) +import GHC.Generics +import Language.Haskell.TH.Syntax (Lift) +import Lens.Micro.Pro +import Lens.Micro.Pro.TH +import Core.Syntax hiding (Lit, Type, Binding, Binding') +import Core (HasRHS(..), HasLHS(..)) +---------------------------------------------------------------------------------- + +data RlpModule p = RlpModule + { _rlpmodName :: Text + , _rlpmodProgram :: RlpProgram p + } + +-- | dear god. +type PhaseShow p = + ( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)) + , Show (XRec p (Lit p)), Show (IdP p) + , Show (XRec p (RlpType p)) + , Show (XRec p (Binding p)) + ) + +newtype RlpProgram p = RlpProgram [Decl' p] + +progDecls :: Lens' (RlpProgram p) [Decl' p] +progDecls = lens + (\ (RlpProgram ds) -> ds) + (const RlpProgram) + +deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p) + +data RlpType p = FunConT + | FunT (RlpType' p) (RlpType' p) + | AppT (RlpType' p) (RlpType' p) + | VarT (IdP p) + | ConT (IdP p) + +type RlpType' p = XRec p (RlpType p) + +pattern FunConT'' :: (UnXRec p) => RlpType' p +pattern FunT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p +pattern AppT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p +pattern VarT'' :: (UnXRec p) => IdP p -> RlpType' p +pattern ConT'' :: (UnXRec p) => IdP p -> RlpType' p + +pattern FunConT'' <- (unXRec -> FunConT) +pattern FunT'' s t <- (unXRec -> FunT s t) +pattern AppT'' s t <- (unXRec -> AppT s t) +pattern VarT'' n <- (unXRec -> VarT n) +pattern ConT'' n <- (unXRec -> ConT n) + +deriving instance (PhaseShow p) + => Show (RlpType p) + +data Decl p = FunD' (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) + | TySigD' (XTySigD p) [IdP p] (RlpType' p) + | DataD' (XDataD p) (IdP p) [IdP p] [ConAlt p] + | InfixD' (XInfixD p) Assoc Int (IdP p) + | XDeclD' !(XXDeclD p) + +deriving instance + ( Show (XFunD p), Show (XTySigD p) + , Show (XDataD p), Show (XInfixD p) + , Show (XXDeclD p) + , PhaseShow p + ) + => Show (Decl p) + +type family XFunD p +type family XTySigD p +type family XDataD p +type family XInfixD p +type family XXDeclD p + +pattern FunD :: (XFunD p ~ ()) + => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p) + -> Decl p +pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p +pattern DataD :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p +pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p +pattern XDeclD :: (XXDeclD p ~ ()) => Decl p + +pattern FunD n as e wh = FunD' () n as e wh +pattern TySigD ns t = TySigD' () ns t +pattern DataD n as cs = DataD' () n as cs +pattern InfixD a p n = InfixD' () a p n +pattern XDeclD = XDeclD' () + +pattern FunD'' :: (UnXRec p) + => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p) + -> Decl' p +pattern TySigD'' :: (UnXRec p) + => [IdP p] -> RlpType' p -> Decl' p +pattern DataD'' :: (UnXRec p) + => IdP p -> [IdP p] -> [ConAlt p] -> Decl' p +pattern InfixD'' :: (UnXRec p) + => Assoc -> Int -> IdP p -> Decl' p + +pattern FunD'' n as e wh <- (unXRec -> FunD' _ n as e wh) +pattern TySigD'' ns t <- (unXRec -> TySigD' _ ns t) +pattern DataD'' n as ds <- (unXRec -> DataD' _ n as ds) +pattern InfixD'' a p n <- (unXRec -> InfixD' _ a p n) + +type Decl' p = XRec p (Decl p) + +data Assoc = InfixL + | InfixR + | Infix + deriving (Show, Lift) + +data ConAlt p = ConAlt (IdP p) [RlpType' p] + +deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p) + +data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p) + | LetrecE' (XLetrecE p) [Binding' p] (RlpExpr' p) + | VarE' (XVarE p) (IdP p) + | LamE' (XLamE p) [Pat p] (RlpExpr' p) + | CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)] + | IfE' (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p) + | AppE' (XAppE p) (RlpExpr' p) (RlpExpr' p) + | LitE' (XLitE p) (Lit p) + | ParE' (XParE p) (RlpExpr' p) + | OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p) + | XRlpExprE' !(XXRlpExprE p) + deriving (Generic) + +type family XLetE p +type family XLetrecE p +type family XVarE p +type family XLamE p +type family XCaseE p +type family XIfE p +type family XAppE p +type family XLitE p +type family XParE p +type family XOAppE p +type family XXRlpExprE p + +pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p +pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p +pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p +pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p +pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p +pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p +pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p +pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p + +pattern LetE bs e = LetE' () bs e +pattern LetrecE bs e = LetrecE' () bs e +pattern VarE n = VarE' () n +pattern LamE as e = LamE' () as e +pattern CaseE e as = CaseE' () e as +pattern IfE c a b = IfE' () c a b +pattern AppE f x = AppE' () f x +pattern LitE l = LitE' () l +pattern ParE e = ParE' () e +pattern OAppE n a b = OAppE' () n a b +pattern XRlpExprE = XRlpExprE' () + +deriving instance + ( Show (XLetE p), Show (XLetrecE p), Show (XVarE p) + , Show (XLamE p), Show (XCaseE p), Show (XIfE p) + , Show (XAppE p), Show (XLitE p), Show (XParE p) + , Show (XOAppE p), Show (XXRlpExprE p) + , PhaseShow p + ) => Show (RlpExpr p) + +type RlpExpr' p = XRec p (RlpExpr p) + +class UnXRec p where + unXRec :: XRec p a -> a + +class WrapXRec p where + wrapXRec :: a -> XRec p a + +class MapXRec p where + mapXRec :: (a -> b) -> XRec p a -> XRec p b + +-- old definition: +-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f +type family XRec p a = (r :: Type) | r -> p a + +type family IdP p + +type IdP' p = XRec p (IdP p) + +type Where p = [Binding p] + +-- do we want guards? +data Alt p = AltA (Pat' p) (RlpExpr' p) + +deriving instance (PhaseShow p) => Show (Alt p) + +data Binding p = PatB (Pat' p) (RlpExpr' p) + | FunB (IdP p) [Pat' p] (RlpExpr' p) + +type Binding' p = XRec p (Binding p) + +pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p +pattern PatB'' p e <- (unXRec -> PatB p e) + +deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p) + ) => Show (Binding p) + +data Pat p = VarP (IdP p) + | LitP (Lit' p) + | ConP (IdP p) [Pat' p] + +pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p +pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p +pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p + +pattern VarP'' n <- (unXRec -> VarP n) +pattern LitP'' l <- (unXRec -> LitP l) +pattern ConP'' c as <- (unXRec -> ConP c as) + +deriving instance (PhaseShow p) => Show (Pat p) + +type Pat' p = XRec p (Pat p) + +data Lit p = IntL Int + | CharL Char + | ListL [RlpExpr' p] + +deriving instance (PhaseShow p) => Show (Lit p) + +type Lit' p = XRec p (Lit p) + +-- instance HasLHS Alt Alt Pat Pat where +-- _lhs = lens +-- (\ (AltA p _) -> p) +-- (\ (AltA _ e) p' -> AltA p' e) + +-- instance HasRHS Alt Alt RlpExpr RlpExpr where +-- _rhs = lens +-- (\ (AltA _ e) -> e) +-- (\ (AltA p _) e' -> AltA p e') + +-- makeBaseFunctor ''RlpExpr + +-- showsTernaryWith :: (Int -> x -> ShowS) +-- -> (Int -> y -> ShowS) +-- -> (Int -> z -> ShowS) +-- -> String -> Int +-- -> x -> y -> z +-- -> ShowS +-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10) +-- $ showString name +-- . showChar ' ' . sa 11 a +-- . showChar ' ' . sb 11 b +-- . showChar ' ' . sc 11 c + +-------------------------------------------------------------------------------- + +makeLenses ''RlpModule +makePrisms ''Pat +makePrisms ''Binding + +-------------------------------------------------------------------------------- + +data RlpExprF p a = LetE'F (XLetE p) [Binding' p] a + | LetrecE'F (XLetrecE p) [Binding' p] a + | VarE'F (XVarE p) (IdP p) + | LamE'F (XLamE p) [Pat p] a + | CaseE'F (XCaseE p) a [(Alt p, Where p)] + | IfE'F (XIfE p) a a a + | AppE'F (XAppE p) a a + | LitE'F (XLitE p) (Lit p) + | ParE'F (XParE p) a + | OAppE'F (XOAppE p) (IdP p) a a + | XRlpExprE'F !(XXRlpExprE p) + deriving (Functor, Foldable, Traversable, Generic) + +type instance Base (RlpExpr p) = RlpExprF p + +instance (UnXRec p) => Recursive (RlpExpr p) where + project = \case + LetE' xx bs e -> LetE'F xx bs (unXRec e) + LetrecE' xx bs e -> LetrecE'F xx bs (unXRec e) + VarE' xx n -> VarE'F xx n + LamE' xx ps e -> LamE'F xx ps (unXRec e) + CaseE' xx e as -> CaseE'F xx (unXRec e) as + IfE' xx a b c -> IfE'F xx (unXRec a) (unXRec b) (unXRec c) + AppE' xx f x -> AppE'F xx (unXRec f) (unXRec x) + LitE' xx l -> LitE'F xx l + ParE' xx e -> ParE'F xx (unXRec e) + OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b) + XRlpExprE' xx -> XRlpExprE'F xx + +instance (WrapXRec p) => Corecursive (RlpExpr p) where + embed = \case + LetE'F xx bs e -> LetE' xx bs (wrapXRec e) + LetrecE'F xx bs e -> LetrecE' xx bs (wrapXRec e) + VarE'F xx n -> VarE' xx n + LamE'F xx ps e -> LamE' xx ps (wrapXRec e) + CaseE'F xx e as -> CaseE' xx (wrapXRec e) as + IfE'F xx a b c -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c) + AppE'F xx f x -> AppE' xx (wrapXRec f) (wrapXRec x) + LitE'F xx l -> LitE' xx l + ParE'F xx e -> ParE' xx (wrapXRec e) + OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b) + XRlpExprE'F xx -> XRlpExprE' xx + diff --git a/src/Rlp/TH.hs b/src/Rlp/TH.hs new file mode 100644 index 0000000..eb4d44c --- /dev/null +++ b/src/Rlp/TH.hs @@ -0,0 +1,36 @@ +module Rlp.TH + ( rlpProg + , rlpExpr + ) + where +-------------------------------------------------------------------------------- +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Data.Text (Text) +import Data.Text qualified as T +import Control.Monad.IO.Class +import Control.Monad + +import Compiler.RLPC +import Rlp.Parse +-------------------------------------------------------------------------------- + +rlpProg :: QuasiQuoter +rlpProg = mkqq parseRlpProgR + +rlpExpr :: QuasiQuoter +rlpExpr = mkqq parseRlpExprR + +mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp +mkq parse = evalAndParse >=> lift where + evalAndParse = liftIO . evalRLPCIO def . parse . T.pack + +mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter +mkqq p = QuasiQuoter + { quoteExp = mkq p + , quotePat = error "rlp quasiquotes may only be used in expressions" + , quoteType = error "rlp quasiquotes may only be used in expressions" + , quoteDec = error "rlp quasiquotes may only be used in expressions" + } + diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs new file mode 100644 index 0000000..b938b74 --- /dev/null +++ b/src/Rlp2Core.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveTraversable #-} +module Rlp2Core + ( desugarRlpProgR + , desugarRlpProg + , desugarRlpExpr + ) + where +-------------------------------------------------------------------------------- +import Control.Monad +import Control.Monad.Writer.CPS +import Control.Monad.Utils +import Control.Arrow +import Control.Applicative +import Control.Comonad +-- import Lens.Micro +-- import Lens.Micro.Internal +import Control.Lens +import Compiler.RLPC +import Data.List (mapAccumL, partition) +import Data.Text (Text) +import Data.Text qualified as T +import Data.HashMap.Strict qualified as H +import Data.Monoid (Endo(..)) +import Data.Either (partitionEithers) +import Data.Foldable +import Data.Fix +import Data.Maybe (fromJust, fromMaybe) +import Data.Functor.Bind +import Data.Function (on) +import GHC.Stack +import Debug.Trace + +import Effectful.State.Static.Local +import Effectful.Labeled +import Effectful +import Text.Show.Deriving + +import Core.Syntax as Core +import Compiler.Types +import Data.Pretty (render, pretty) +import Rlp.Syntax as Rlp +import Rlp.Parse.Types (RlpcPs, PsName) +-------------------------------------------------------------------------------- + +type Tree a = Either Name (Name, Branch a) + +-- | Rose tree branch representing "nested" "patterns" in the Core language. That +-- is, a constructor with children that are either a normal binder (Left (Given) +-- name) or an indirection to another pattern (Right (Generated name) (Pattern)) + +data Branch a = Branch Name [Tree a] + deriving (Show, Functor, Foldable, Traversable) + +-- | The actual rose tree. +-- @type Rose = 'Data.Fix.Fix' 'Branch'@ + +type Rose = Fix Branch + +deriveShow1 ''Branch + +-------------------------------------------------------------------------------- + +desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program' +desugarRlpProgR p = do + let p' = desugarRlpProg p + addDebugMsg "dump-desugared" $ render (pretty p') + pure p' + +desugarRlpProg :: RlpProgram RlpcPs -> Program' +desugarRlpProg = rlpProgToCore + +desugarRlpExpr :: RlpExpr RlpcPs -> Expr' +desugarRlpExpr = runPureEff . runNameSupply "anon" . exprToCore + +-- the rl' program is desugared by desugaring each declaration as a separate +-- program, and taking the monoidal product of the lot :3 + +rlpProgToCore :: RlpProgram RlpcPs -> Program' +rlpProgToCore = foldMapOf (progDecls . each) declToCore + +declToCore :: Decl' RlpcPs -> Program' + +declToCore (TySigD'' ns t) = mempty & + programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ] + +declToCore (DataD'' n as ds) = fold . getZipList $ + constructorToCore t' <$> ZipList [0..] <*> ZipList ds + where + -- create the appropriate type from the declared constructor and its + -- arguments + t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as) + +-- TODO: where-binds +declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e'] + where + n' = dsNameToName n + e' = runPureEff . runNameSupply n . exprToCore . unXRec $ e + as' = as <&> \case + (unXRec -> VarP k) -> dsNameToName k + _ -> error "no patargs yet" + +type NameSupply = Labeled NameSupplyLabel (State [IdP RlpcPs]) +type NameSupplyLabel = "expr-name-supply" + +exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr' + +exprToCore (VarE n) = pure $ Var (dsNameToName n) + +exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b + +exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b + where + mkApp s t = (Var f `App` s) `App` t + +exprToCore (CaseE (unXRec -> e) as) = do + e' <- exprToCore e + Case e' <$> caseAltToCore `traverse` as + +exprToCore (LetE bs e) = letToCore NonRec bs e +exprToCore (LetrecE bs e) = letToCore Rec bs e + +exprToCore (LitE l) = litToCore l + +letToCore :: forall es. (NameSupply :> es) + => Rec -> [Rlp.Binding' RlpcPs] -> RlpExpr' RlpcPs -> Eff es Expr' +letToCore r bs e = do + -- TODO: preserve binder order. + (bs',as) <- getParts + let insbs | null bs' = pure + | otherwise = pure . Let r bs' + appKendo (foldMap Kendo (as `snoc` insbs)) <=< exprToCore $ unXRec e + where + -- partition & map the list of binders into: + -- bs' : the let-binds that may be directly translated to Core + -- let-binds (we do exactly that). this is all the binders that + -- are a simple variable rather than a pattern match. + -- and as : the let-binds that may **not** be directly translated to + -- Core let-exprs. they get turned into case alternates. + getParts = traverse f bs <&> partitionEithers + + f :: Rlp.Binding' RlpcPs + -> Eff es (Either Core.Binding' (Expr' -> Eff es Expr')) + f (PatB'' (VarP'' n) e) = Left . (n :=) <$> exprToCore (unXRec e) + f (PatB'' p e) = pure $ Right (caseify p e) + +litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr' +litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n + +{- +let C x = y +in e + +case y of + C x -> e + -} + +caseify :: (NameSupply :> es) + => Pat' RlpcPs -> RlpExpr' RlpcPs -> Expr' -> Eff es Expr' +caseify p (unXRec -> e) i = + Case <$> exprToCore e <*> ((:[]) <$> alt) + where + alt = conToRose (unXRec p) <&> foldFix (branchToCore i) + +-- TODO: where-binds +caseAltToCore :: (HasCallStack, NameSupply :> es) + => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter' +caseAltToCore (AltA (unXRec -> p) e, wh) = do + e' <- exprToCore . unXRec $ e + conToRose p <&> foldFix (branchToCore e') + +altToCore :: (NameSupply :> es) + => Alt RlpcPs -> Eff es Alter' +altToCore (AltA p e) = altToCore' p e + +altToCore' :: (NameSupply :> es) + => Pat' RlpcPs -> RlpExpr' RlpcPs -> Eff es Alter' +altToCore' (unXRec -> p) (unXRec -> e) = do + e' <- exprToCore e + conToRose p <&> foldFix (branchToCore e') + +conToRose :: forall es. (HasCallStack, NameSupply :> es) => Pat RlpcPs -> Eff es Rose +conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as + where + patToForrest :: Pat' RlpcPs -> Eff es (Tree Rose) + patToForrest (VarP'' x) = pure $ Left (dsNameToName x) + patToForrest p@(ConP'' _ _) = + Right <$> liftA2 (,) uniqueName br + where + br = unwrapFix <$> conToRose (unXRec p) +conToRose s = error $ "conToRose: not a ConP!: " <> show s + +branchToCore :: Expr' -> Branch Alter' -> Alter' +branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e' + where + -- gather binders for the /current/ pattern, and build an expression + -- matching subpatterns + (e', myBinds) = mapAccumL f e as + + f :: Expr' -> Tree Alter' -> (Expr', Name) + f e (Left n) = (e, dsNameToName n) + f e (Right (n,cs)) = (e', dsNameToName n) where + e' = Case (Var $ dsNameToName n) [branchToCore e cs] + +runNameSupply :: IdP RlpcPs -> Eff (NameSupply ': es) a -> Eff es a +runNameSupply n = runLabeled @NameSupplyLabel (evalState ns) where + ns = [ "$" <> n <> "_" <> T.pack (show k) | k <- [0..] ] + +-- | debug helper + +nameSupply :: [IdP RlpcPs] +nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ] + +uniqueName :: (NameSupply :> es) => Eff es (IdP RlpcPs) +uniqueName = labeled @NameSupplyLabel @(State [IdP RlpcPs]) $ + state @[IdP RlpcPs] (fromMaybe err . uncons) + where + err = error "NameSupply ran out of names! This shound never happen.\ + \ The caller of runNameSupply is responsible." + +constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program' +constructorToCore t tag (ConAlt cn as) = + mempty & programTypeSigs . at cn ?~ foldr (:->) t as' + & programDataTags . at cn ?~ (tag, length as) + where + as' = typeToCore <$> as + +typeToCore :: RlpType' RlpcPs -> Type +typeToCore FunConT'' = TyFun +typeToCore (FunT'' s t) = typeToCore s :-> typeToCore t +typeToCore (AppT'' s t) = TyApp (typeToCore s) (typeToCore t) +typeToCore (ConT'' n) = TyCon (dsNameToName n) +typeToCore (VarT'' x) = TyVar (dsNameToName x) + +-- | Forwards-compatiblity if IdP RlpDs is changed +dsNameToName :: IdP RlpcPs -> Name +dsNameToName = id + diff --git a/tst/Arith.hs b/tst/Arith.hs index ea91311..2bfb7ed 100644 --- a/tst/Arith.hs +++ b/tst/Arith.hs @@ -6,6 +6,7 @@ module Arith ) where ---------------------------------------------------------------------------------- import Data.Functor.Classes (eq1) +import Lens.Micro import Core.Syntax import GM import Test.QuickCheck @@ -40,6 +41,7 @@ evalArith (a ::* b) = evalArith a * evalArith b evalArith (a ::- b) = evalArith a - evalArith b instance Arbitrary ArithExpr where + -- TODO: implement shrink arbitrary = gen 4 where gen :: Int -> Gen ArithExpr @@ -70,13 +72,13 @@ instance Arbitrary ArithExpr where -- coreResult = evalCore (toCore e) toCore :: ArithExpr -> Program' -toCore expr = Program +toCore expr = mempty & programScDefs .~ [ ScDef "id" ["x"] $ Var "x" , ScDef "main" [] $ go expr ] where go :: ArithExpr -> Expr' - go (IntA n) = LitE (IntL n) + go (IntA n) = Lit (IntL n) go (NegateA e) = "negate#" :$ go e go (IdA e) = "id" :$ go e go (a :+ b) = f "+#" a b diff --git a/tst/Core/HindleyMilnerSpec.hs b/tst/Core/HindleyMilnerSpec.hs new file mode 100644 index 0000000..97e4732 --- /dev/null +++ b/tst/Core/HindleyMilnerSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +module Core.HindleyMilnerSpec + ( spec + ) + where +---------------------------------------------------------------------------------- +import Core.Syntax +import Core.TH (coreExpr) +import Core.HindleyMilner +import Control.Monad.Errorful +import Data.Either (isLeft) +import Test.Hspec +---------------------------------------------------------------------------------- + +-- TODO: more tests. preferrably property-based. lol. +spec :: Spec +spec = do + it "should infer `id 3` :: Int" $ + let g = [ ("id", "a" :-> "a") ] + in infer' g [coreExpr|id 3|] `shouldBe` Right TyInt + + it "should not infer `id 3` when `id` is specialised to `a -> a`" $ + let g = [ ("id", ("a" :-> "a") :-> "a" :-> "a") ] + in infer' g [coreExpr|id 3|] `shouldSatisfy` isLeft + + -- TODO: property-based tests for let + it "should infer `let x = 3 in id x` :: Int" $ + let g = [ ("id", "a" :-> "a") ] + e = [coreExpr|let {x = 3} in id x|] + in infer' g e `shouldBe` Right TyInt + + it "should infer `let x = 3; y = 2 in (+#) x y` :: Int" $ + let g = [ ("+#", TyInt :-> TyInt :-> TyInt) ] + e = [coreExpr|let {x=3;y=2} in (+#) x y|] + in infer' g e `shouldBe` Right TyInt + + it "should find `3 :: Bool` contradictory" $ + let e = [coreExpr|3|] + in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft + + it "should infer `fix ((+#) 1)` :: Int" $ + let g = [ ("fix", ("a" :-> "a") :-> "a") + , ("+#", TyInt :-> TyInt :-> TyInt) ] + e = [coreExpr|fix ((+#) 1)|] + in infer' g e `shouldBe` Right TyInt + + it "should infer mutually recursively defined lists" $ + let g = [ ("cons", TyInt :-> TyCon "IntList" :-> TyCon "IntList") ] + e :: Expr' + e = [coreExpr|letrec { as = cons 1 bs; bs = cons 2 as } in as|] + in infer' g e `shouldBe` Right (TyCon "IntList") + +infer' :: Context' -> Expr' -> Either [TypeError] Type +infer' g e = case runErrorful $ infer g e of + (Just t, _) -> Right t + (Nothing, es) -> Left es + +check' :: Context' -> Type -> Expr' -> Either [TypeError] () +check' g t e = case runErrorful $ check g t e of + (Just t, _) -> Right () + (Nothing, es) -> Left es + diff --git a/tst/GMSpec.hs b/tst/GMSpec.hs index dd5957a..cc5faf1 100644 --- a/tst/GMSpec.hs +++ b/tst/GMSpec.hs @@ -27,15 +27,22 @@ spec = do in coreRes `shouldBe` arithRes describe "test programs" $ do - it "fac 3" $ do + it "fac 3" $ resultOf Ex.fac3 `shouldBe` Just (NNum 6) - it "sum [1,2,3]" $ do + it "sum [1,2,3]" $ resultOf Ex.sumList `shouldBe` Just (NNum 6) - it "k 3 ((/#) 1 0)" $ do + it "k 3 ((/#) 1 0)" $ resultOf Ex.constDivZero `shouldBe` Just (NNum 3) - it "id (case ... of { ... })" $ do + it "id (case ... of { ... })" $ resultOf Ex.idCase `shouldBe` Just (NNum 5) + it "bool pattern matching with named constructors" $ + resultOf Ex.namedBoolCase `shouldBe` Just (NNum 123) + + it "list pattern matching with named constructors" $ + resultOf Ex.namedConsCase `shouldBe` Just (NNum 6) + +