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

Compare commits

base: msyds:errorful
Branches Tags
msyds:main msyds:gm-visualiser-2 msyds:dev msyds:bottom-up-hm msyds:functor-sum-test msyds:sysf msyds:no-ttg msyds:gm-visualiser msyds:ugh msyds:errorful msyds:ttg msyds:errorful-everything msyds:named-core-case msyds:frontend-parser msyds:hm msyds:rlp2core msyds:happy-frontend msyds:test-syntax msyds:test-example-programs
msyds:v0.1.0 msyds:v0.0.0-alpha
..
compare: msyds:frontend-parser
Branches Tags
msyds:gm-visualiser-2 msyds:dev msyds:main msyds:bottom-up-hm msyds:functor-sum-test msyds:sysf msyds:no-ttg msyds:gm-visualiser msyds:ugh msyds:errorful msyds:ttg msyds:errorful-everything msyds:named-core-case msyds:frontend-parser msyds:hm msyds:rlp2core msyds:happy-frontend msyds:test-syntax msyds:test-example-programs
msyds:v0.1.0 msyds:v0.0.0-alpha

1 Commits
errorful ... frontend-p

Author SHA1 Message Date
crumbtoo
5ce11dfdd7 RlpExpr LetE Rec 2024-01-23 21:24:14 -07:00
33 changed files with 681 additions and 1240 deletions
Expand all files Collapse all files

19
CHANGELOG.md
View File

@@ -1,19 +0,0 @@
# 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

2
Makefile_happysrcs
View File

@@ -1,5 +1,5 @@
HAPPY = happy HAPPY = happy
HAPPY_OPTS = -a -g -c -i/tmp/t.info HAPPY_OPTS = -a -g -c
ALEX = alex ALEX = alex
ALEX_OPTS = -g ALEX_OPTS = -g

65
README.md
View File

@@ -23,19 +23,19 @@ $ cabal test --test-show-details=direct
$ rlpc -ddump-eval examples/factorial.hs $ rlpc -ddump-eval examples/factorial.hs
# Compile and evaluate t.hs, with evaluation info dumped to t.log # Compile and evaluate t.hs, with evaluation info dumped to t.log
$ rlpc -ddump-eval -l t.log t.hs $ rlpc -ddump-eval -l t.log t.hs
# Print the raw structure describing the compiler options # Print the raw structure describing the compiler options and die
# (option parsing still must succeed in order to print) # (option parsing still must succeed in order to print)
$ rlpc -ddump-opts t.hs $ rlpc -ddump-opts t.hs
``` ```
### Potential Features ### Potential Features
Listed in order of importance. Listed in order of importance.
- [x] ADTs - [ ] ADTs
- [x] First-class functions - [ ] First-class functions
- [ ] Higher-kinded types - [ ] Higher-kinded types
- [ ] Typeclasses - [ ] Typeclasses
- [x] Parametric polymorphism - [ ] Parametric polymorphism
- [x] Hindley-Milner type inference - [ ] Hindley-Milner type inference
- [ ] Newtype coercion - [ ] Newtype coercion
- [ ] Parallelism - [ ] Parallelism
@@ -66,61 +66,32 @@ Listed in order of importance.
- [ ] TCO - [ ] TCO
- [ ] DCE - [ ] DCE
- [ ] Frontend - [ ] Frontend
- [x] High-level language - [ ] High-level language
- [x] AST - [ ] AST
- [x] Lexer - [ ] Lexer
- [x] Parser - [ ] Parser
- [ ] Translation to the core language - [ ] Translation to the core language
- [ ] Constraint solver - [ ] Constraint solver
- [ ] `do`-notation - [ ] `do`-notation
- [x] CLI - [x] CLI
- [ ] Documentation - [ ] Documentation
- [x] State transition rules - [ ] State transition rules
- [ ] How does the evaluation model work? - [ ] How does the evaluation model work?
- [ ] The Hindley-Milner type system
- [ ] CLI usage - [ ] CLI usage
- [ ] Tail call optimisation - [ ] Tail call optimisation
- [ ] Parsing rlp - [x] Parsing rlp
- [ ] Trees That Grow
- [ ] Tests - [ ] Tests
- [x] Generic example programs - [x] Generic example programs
- [ ] Parser - [ ] Parser
### ~~December Release Plan~~ ### December Release Plan
- [x] Tests - [ ] Tests
- [ ] Core lexer - [ ] Core lexer
- [ ] Core parser - [ ] Core parser
- [x] Evaluation model - [ ] Evaluation model
- [ ] Benchmarks - [ ] Benchmarks
- [x] Stable Core lexer - [ ] Stable Core lexer
- [x] Stable Core parser - [ ] Stable Core parser
- [x] Stable evaluation model - [ ] Stable evaluation model
- [x] Garbage Collection - [ ] Garbage Collection
- [ ] Stable documentation for the evaluation model - [ ] Stable documentation for the evaluation model
### January Release Plan
- [ ] Beta rl' to Core
- [ ] UX improvements
- [ ] Actual compiler errors -- no more unexceptional `error` calls
- [ ] Better CLI dump flags
- [ ] Annotate the AST with token positions for errors
- [ ] More examples
### March Release Plan
- [ ] Tests
- [ ] rl' parser
- [ ] rl' lexer
### Indefinite Release Plan
This list is more concrete than the milestones, but likely further in the future
than the other release plans.
- [ ] Stable rl' to Core
- [ ] Core polish
- [ ] Better, stable parser
- [ ] Better, stable lexer
- [ ] Less hacky handling of named data
- [ ] Less hacky pragmas
- [ ] GM to LLVM

17
app/CoreDriver.hs
View File

@@ -1,17 +0,0 @@
module CoreDriver
( driver
)
where
--------------------------------------------------------------------------------
import Compiler.RLPC
import Control.Monad
import Core.Lex
import Core.Parse
import GM
--------------------------------------------------------------------------------
driver :: RLPCIO ()
driver = forFiles_ $ \f ->
withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)

107
app/Main.hs
View File

@@ -10,16 +10,12 @@ import Data.HashSet qualified as S
import Data.Text (Text) import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.IO qualified as TIO import Data.Text.IO qualified as TIO
import Data.List
import System.IO import System.IO
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import Core import Core
import TI import TI
import GM import GM
import Lens.Micro.Mtl import Lens.Micro.Mtl
import CoreDriver qualified
import RlpDriver qualified
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
optParser :: ParserInfo RLPCOptions optParser :: ParserInfo RLPCOptions
@@ -41,15 +37,9 @@ options = RLPCOptions
{- -d -} {- -d -}
<*> fmap S.fromList # many # option debugFlagReader <*> fmap S.fromList # many # option debugFlagReader
( short 'd' ( short 'd'
<> help "pass debug flags" <> help "dump evaluation logs"
<> metavar "DEBUG FLAG" <> metavar "DEBUG FLAG"
) )
{- -f -}
<*> fmap S.fromList # many # option compilerFlagReader
( short 'f'
<> help "pass compilation flags"
<> metavar "COMPILATION FLAG"
)
{- --evaluator, -e -} {- --evaluator, -e -}
<*> option evaluatorReader <*> option evaluatorReader
( long "evaluator" ( long "evaluator"
@@ -65,45 +55,96 @@ options = RLPCOptions
\triggering the garbage collector" \triggering the garbage collector"
<> value 50 <> value 50
) )
<*> option languageReader
( long "language"
<> short 'x'
)
<*> some (argument str $ metavar "FILES...") <*> some (argument str $ metavar "FILES...")
where where
infixr 9 # infixr 9 #
f # x = f x f # x = f x
languageReader :: ReadM Language
languageReader = maybeReader $ \case
"rlp" -> Just LanguageRlp
"core" -> Just LanguageCore
_ -> Nothing
debugFlagReader :: ReadM DebugFlag
debugFlagReader = str
compilerFlagReader :: ReadM CompilerFlag
compilerFlagReader = str
evaluatorReader :: ReadM Evaluator evaluatorReader :: ReadM Evaluator
evaluatorReader = maybeReader $ \case evaluatorReader = maybeReader $ \case
"gm" -> Just EvaluatorGM "gm" -> Just EvaluatorGM
"ti" -> Just EvaluatorTI "tim" -> Just EvaluatorTI
_ -> Nothing _ -> Nothing
mmany :: (Alternative f, Monoid m) => f m -> f m mmany :: (Alternative f, Monoid m) => f m -> f m
mmany v = liftA2 (<>) v (mmany v) 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 :: IO ()
main = do main = do
opts <- execParser optParser opts <- execParser optParser
void $ evalRLPCIO opts driver (_, es) <- evalRLPCIO opts driver
forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
pure ()
driver :: RLPCIO () driver :: RLPCIO CompilerError ()
driver = view rlpcLanguage >>= \case driver = sequence_
LanguageCore -> CoreDriver.driver [ dshowFlags
LanguageRlp -> RlpDriver.driver , ddumpAST
, ddumpEval
]
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 <- TIO.hGetContents h
case parseProg o s of
Right (a,_) -> hPutStrLn stderr $ show a
Left e -> error "todo errors lol"
ddumpEval :: RLPCIO CompilerError ()
ddumpEval = whenFlag flagDDumpEval do
fs <- view rlpcInputFiles
forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
where
doProg :: Text -> 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
-> Text
-> 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)

11
app/RlpDriver.hs
View File

@@ -1,11 +0,0 @@
module RlpDriver
( driver
)
where
--------------------------------------------------------------------------------
import Compiler.RLPC
--------------------------------------------------------------------------------
driver :: RLPCIO ()
driver = undefined

2
doc/src/commentary/gm.rst
View File

@@ -112,3 +112,5 @@ The way around this is quite simple: simply offset the stack when w
:end-before: -- << [ref/compileC] :end-before: -- << [ref/compileC]
:caption: src/GM.hs :caption: src/GM.hs

73
doc/src/commentary/layout-lexing.rst
View File

@@ -2,21 +2,16 @@ Lexing, Parsing, and Layouts
============================ ============================
The C-style languages of my previous experiences have all had quite trivial The C-style languages of my previous experiences have all had quite trivial
lexical analysis stages: you ignore all whitespace and point out the symbols you lexical analysis stages, peaking in complexity when I streamed tokens lazily in
recognise. If you don't recognise something, check if it's a literal or an C. The task of tokenising a C-style language is very simple in description: you
identifier. Should it be neither, return an error. 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.
In contrast, both lexing and parsing a Haskell-like language poses a number of On paper, both lexing and parsing a Haskell-like language seem to pose a few
greater challenges. Listed by ascending intimidation factor, some of the greater challenges. Listed by ascending intimidation factor, some of the
potential roadblocks on my mind before making an attempt were: 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 * Operators; Haskell has not only user-defined infix operators, but user-defined
precedence levels and associativities. I recall using an algorithm that looked 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 up infix, prefix, postfix, and even mixfix operators up in a global table to
@@ -24,9 +19,17 @@ potential roadblocks on my mind before making an attempt were:
stored in the table). I never modified the table at runtime, however this stored in the table). I never modified the table at runtime, however this
could be a very nice solution for Haskell. 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 * Whitespace sensitivity; While I was comfortable with the idea of a system
similar to Python's INDENT/DEDENT tokens, Haskell's layout system is based on similar to Python's INDENT/DEDENT tokens, Haskell seemed to use whitespace to
alignment and is very generous with line-folding. section code in a way that *felt* different.
.. _note: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/coding-style#2-using-notes .. _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 .. _GHC's lexer: https://gitlab.haskell.org/ghc/ghc/-/blob/master/compiler/GHC/Parser/Lexer.x#L1133
@@ -42,9 +45,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 Python uses newlines and indentation to separate statements and resolve scope
instead of the traditional semicolons and braces found in C-style languages (we instead of the traditional semicolons and braces found in C-style languages (we
may generally refer to these C-style languages as *explicitly-sectioned*). may generally refer to these C-style languages as *explicitly-sectioned*).
Internally during tokenisation, when the Python lexer encounters a new line, the Internally during tokenisation, when the Python lexer begins a new line, they
indentation of the new line is compared with that of the previous and the compare the indentation of the new line with that of the previous and apply the
following rules are applied: following rules:
1. If the new line has greater indentation than the previous, insert an INDENT 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 token and push the new line's indentation level onto the indentation stack
@@ -57,37 +60,44 @@ following rules are applied:
3. If the indentation is equal, insert a NEWLINE token to terminate the previous 3. If the indentation is equal, insert a NEWLINE token to terminate the previous
line, and leave it at that! line, and leave it at that!
On the parser's end, the INDENT, DEDENT, and NEWLINE tokens are identical to Parsing Python with the INDENT, DEDENT, and NEWLINE tokens is identical to
braces and semicolons. In developing our *layout* rules, we will follow in the parsing a language with braces and semicolons. This is a solution pretty in line
pattern of translating the whitespace-sensitive source language to an explicitly with Python's philosophy of the "one correct answer" (TODO: this needs a
sectioned language. 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? But What About Haskell?
*********************** ***********************
Parsing Haskell -- and thus rl' -- is only slightly more complex than Python, We saw that Python, the most notable example of an implicitly sectioned
but the design is certainly more sensitive. 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 .. code-block:: haskell
-- line folds -- line continuation
something = this is a something = this is a
single expression single expression
-- an extremely common style found in haskell -- an extremely common style found in haskell
data Some = Data data Python = Users
{ is :: Presented { are :: Crying
, in :: This , right :: About
, silly :: Style , now :: Sorry
} }
-- another style oddity -- another formatting oddity
-- note that this is not a single -- note that this is not a single
-- continued line! `look at`, -- continued line! `look at`,
-- `this odd`, and `alignment` are all -- `this`, and `alignment` are all
-- discrete items! -- separate expressions!
anotherThing = do look at anotherThing = do look at
this odd this
alignment alignment
But enough fear, lets actually think about implementation. Firstly, some But enough fear, lets actually think about implementation. Firstly, some
@@ -223,4 +233,3 @@ References
* `Haskell syntax reference * `Haskell syntax reference
<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_

5
doc/src/commentary/type-inference.rst
View File

@@ -1,5 +0,0 @@
Type Inference in rl'
=====================
rl' implements type inference via the Hindley-Milner type system.

17
doc/src/references/rlp-inference-rules.rst
View File

@@ -1,17 +0,0 @@
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}

4
examples/factorial.hs
View File

@@ -1,6 +1,6 @@
fac n = case (==#) n 0 of fac n = case (==#) n 0 of
{ <1> -> 1 { 1 -> 1
; <0> -> (*#) n (fac ((-#) n 1)) ; 0 -> (*#) n (fac ((-#) n 1))
}; };
main = fac 3; main = fac 3;

4
examples/sumList.hs
View File

@@ -2,8 +2,8 @@ nil = Pack{0 0};
cons x y = Pack{1 2} x y; cons x y = Pack{1 2} x y;
list = cons 1 (cons 2 (cons 3 nil)); list = cons 1 (cons 2 (cons 3 nil));
sum l = case l of sum l = case l of
{ <0> -> 0 { 0 -> 0
; <1> x xs -> (+#) x (sum xs) ; 1 x xs -> (+#) x (sum xs)
}; };
main = sum list; main = sum list;

105
programming-language-checklist
View File

@@ -1,105 +0,0 @@
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.

21
rlp.cabal
View File

@@ -7,7 +7,7 @@ license: GPL-2.0-only
-- license-file: LICENSE -- license-file: LICENSE
author: crumbtoo author: crumbtoo
maintainer: crumb@disroot.org maintainer: crumb@disroot.org
copyright: Madeleine Sydney Ślaga -- copyright:
category: Language category: Language
build-type: Simple build-type: Simple
extra-doc-files: README.md extra-doc-files: README.md
@@ -37,8 +37,8 @@ library
, Rlp.Parse.Associate , Rlp.Parse.Associate
, Rlp.Lex , Rlp.Lex
, Rlp.Parse.Types , Rlp.Parse.Types
, Compiler.Types
, Data.Heap other-modules: Data.Heap
, Data.Pretty , Data.Pretty
, Core.Parse , Core.Parse
, Core.Lex , Core.Lex
@@ -48,7 +48,7 @@ library
build-tool-depends: happy:happy, alex:alex build-tool-depends: happy:happy, alex:alex
-- other-extensions: -- other-extensions:
build-depends: base >=4.17 && <4.20 build-depends: base ^>=4.18.0.0
-- required for happy -- required for happy
, array >= 0.5.5 && < 0.6 , array >= 0.5.5 && < 0.6
, containers >= 0.6.7 && < 0.7 , containers >= 0.6.7 && < 0.7
@@ -69,26 +69,19 @@ library
, data-fix >= 0.3.2 && < 0.4 , data-fix >= 0.3.2 && < 0.4
, utf8-string >= 1.0.2 && < 1.1 , utf8-string >= 1.0.2 && < 1.1
, extra >= 1.7.0 && < 2 , extra >= 1.7.0 && < 2
, semigroupoids
, comonad
, lens
, text-ansi
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2021 default-language: GHC2021
default-extensions: default-extensions:
OverloadedStrings OverloadedStrings
TypeFamilies
LambdaCase
executable rlpc executable rlpc
import: warnings import: warnings
main-is: Main.hs main-is: Main.hs
other-modules: RlpDriver -- other-modules:
, CoreDriver -- other-extensions:
build-depends: base ^>=4.18.0.0
build-depends: base >=4.17.0.0 && <4.20.0.0
, rlp , rlp
, optparse-applicative >= 0.18.1 && < 0.19 , optparse-applicative >= 0.18.1 && < 0.19
, microlens >= 0.4.13 && < 0.5 , microlens >= 0.4.13 && < 0.5

216
src/Compiler/RLPC.hs
View File

@@ -11,81 +11,64 @@ errors and the family of RLPC monads.
-- only used for mtl instances -- only used for mtl instances
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-} {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
{-# LANGUAGE BlockArguments, ViewPatterns #-}
module Compiler.RLPC module Compiler.RLPC
( ( RLPC
-- * Rlpc Monad transformer , RLPCT(..)
RLPCT(RLPCT), , RLPCIO
-- ** Special cases , RLPCOptions(RLPCOptions)
RLPC, RLPCIO , IsRlpcError(..)
-- ** Running , RlpcError(..)
, runRLPCT , MsgEnvelope(..)
, evalRLPCT, evalRLPCIO, evalRLPC , addFatal
-- * Rlpc options , addWound
, Language(..), Evaluator(..) , MonadErrorful
, DebugFlag(..), CompilerFlag(..) , Severity(..)
-- ** Lenses , Evaluator(..)
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage , evalRLPCT
-- * Misc. MTL-style functions , evalRLPCIO
, liftErrorful, hoistRlpcT , evalRLPC
-- * Misc. Rlpc Monad -related types , rlpcLogFile
, RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..) , rlpcDebugOpts
, MsgEnvelope(..), Severity(..) , rlpcEvaluator
, addDebugMsg , rlpcInputFiles
, whenDFlag, whenFFlag , DebugFlag(..)
-- * Misc. Utilities , whenFlag
, forFiles_, withSource , flagDDumpEval
-- * Convenient re-exports , flagDDumpOpts
, addFatal, addWound, def , flagDDumpAST
, def
, liftErrorful
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Control.Exception import Control.Exception
import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State (MonadState(state)) import Control.Monad.State (MonadState(state))
import Control.Monad.Errorful import Control.Monad.Errorful
import Control.Monad.IO.Class
import Compiler.RlpcError import Compiler.RlpcError
import Compiler.Types
import Data.Functor.Identity import Data.Functor.Identity
import Data.Default.Class import Data.Default.Class
import Data.Foldable import Data.Foldable
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Data.Maybe
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import Data.HashSet qualified as S import Data.HashSet qualified as S
import Data.Coerce import Data.Coerce
import Data.Text (Text) import Lens.Micro
import Data.Text qualified as T import Lens.Micro.TH
import Data.Text.IO qualified as T
import Text.ANSI qualified as Ansi
import Text.PrettyPrint hiding ((<>))
import Lens.Micro.Platform
import Lens.Micro.Platform.Internal
import System.Exit import System.Exit
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
newtype RLPCT m a = RLPCT { newtype RLPCT m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
} }
deriving ( Functor, Applicative, Monad deriving (Functor, Applicative, Monad)
, MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
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
type RLPC = RLPCT Identity type RLPC = RLPCT Identity
type RLPCIO = RLPCT IO type RLPCIO = RLPCT IO
instance (MonadIO m) => MonadIO (RLPCT m) where
evalRLPC :: RLPCOptions evalRLPC :: RLPCOptions
-> RLPC a -> RLPC a
-> (Maybe a, [MsgEnvelope RlpcError]) -> (Maybe a, [MsgEnvelope RlpcError])
@@ -93,28 +76,31 @@ evalRLPC opt r = runRLPCT r
& flip runReaderT opt & flip runReaderT opt
& runErrorful & runErrorful
evalRLPCT :: RLPCOptions evalRLPCT :: (Monad m)
=> RLPCOptions
-> RLPCT m a -> RLPCT m a
-> m (Maybe a, [MsgEnvelope RlpcError]) -> m (Maybe a, [MsgEnvelope RlpcError])
evalRLPCT opt r = runRLPCT r evalRLPCT = undefined
& flip runReaderT opt
& runErrorfulT evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
evalRLPCIO opt r = do
(ma,es) <- evalRLPCT opt r
putRlpcErrs es
case ma of
Just x -> pure x
Nothing -> die "Failed, no code compiled."
putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
putRlpcErrs = traverse_ print
liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) 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 data RLPCOptions = RLPCOptions
{ _rlpcLogFile :: Maybe FilePath { _rlpcLogFile :: Maybe FilePath
, _rlpcDFlags :: HashSet DebugFlag , _rlpcDebugOpts :: DebugOpts
, _rlpcFFlags :: HashSet CompilerFlag
, _rlpcEvaluator :: Evaluator , _rlpcEvaluator :: Evaluator
, _rlpcHeapTrigger :: Int , _rlpcHeapTrigger :: Int
, _rlpcLanguage :: Language
, _rlpcInputFiles :: [FilePath] , _rlpcInputFiles :: [FilePath]
} }
deriving Show deriving Show
@@ -122,117 +108,43 @@ data RLPCOptions = RLPCOptions
data Evaluator = EvaluatorGM | EvaluatorTI data Evaluator = EvaluatorGM | EvaluatorTI
deriving Show deriving Show
data Language = LanguageRlp | LanguageCore
deriving Show
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
instance Default RLPCOptions where instance Default RLPCOptions where
def = RLPCOptions def = RLPCOptions
{ _rlpcLogFile = Nothing { _rlpcLogFile = Nothing
, _rlpcDFlags = mempty , _rlpcDebugOpts = mempty
, _rlpcFFlags = mempty
, _rlpcEvaluator = EvaluatorGM , _rlpcEvaluator = EvaluatorGM
, _rlpcHeapTrigger = 200 , _rlpcHeapTrigger = 200
, _rlpcInputFiles = [] , _rlpcInputFiles = []
, _rlpcLanguage = LanguageRlp
} }
-- debug flags are passed with -dFLAG type DebugOpts = HashSet DebugFlag
type DebugFlag = Text
type CompilerFlag = Text data DebugFlag = DDumpEval
| DDumpOpts
| DDumpAST
deriving (Show, Eq, Generic)
instance Hashable DebugFlag
makeLenses ''RLPCOptions makeLenses ''RLPCOptions
pure [] pure []
addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m () whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed] whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
-- TODO: rewrite this with prisms once microlens-pro drops :3 -- there's probably a better way to write this. my current knowledge of lenses
whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m () -- is too weak.
whenDFlag f m = do flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
-- mfw no `At` instance for HashSet flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
fs <- view rlpcDFlags
let a = S.member f fs
when a m
whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m () flagDDumpEval :: SimpleGetter RLPCOptions Bool
whenFFlag f m = do flagDDumpEval = flagGetter DDumpEval
-- 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
evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a flagDDumpAST :: SimpleGetter RLPCOptions Bool
evalRLPCIO opt r = do flagDDumpAST = flagGetter DDumpAST
(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 opts = filter byTag
>>> traverse_ (putStrLn . ('\n':) . prettyRlpcMsg)
where
dflags = opts ^. rlpcDFlags
byTag :: MsgEnvelope RlpcError -> Bool
byTag (view msgSeverity -> SevDebug t) =
t `S.member` dflags
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 = ["", "<problematic source code>", ""]
filename = msgColour "<input>"
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

21
src/Compiler/RlpcError.hs
View File

@@ -5,15 +5,12 @@ module Compiler.RlpcError
, MsgEnvelope(..) , MsgEnvelope(..)
, Severity(..) , Severity(..)
, RlpcError(..) , RlpcError(..)
, SrcSpan(..)
, msgSpan , msgSpan
, msgDiagnostic , msgDiagnostic
, msgSeverity , msgSeverity
, liftRlpcErrors , liftRlpcErrors
, errorMsg , errorMsg
, debugMsg
-- * Located Comonad
, Located(..)
, SrcSpan(..)
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -23,7 +20,6 @@ import Data.Text qualified as T
import GHC.Exts (IsString(..)) import GHC.Exts (IsString(..))
import Lens.Micro.Platform import Lens.Micro.Platform
import Lens.Micro.Platform.Internal import Lens.Micro.Platform.Internal
import Compiler.Types
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data MsgEnvelope e = MsgEnvelope data MsgEnvelope e = MsgEnvelope
@@ -47,7 +43,12 @@ instance IsRlpcError RlpcError where
data Severity = SevWarning data Severity = SevWarning
| SevError | SevError
| SevDebug Text deriving Show
data SrcSpan = SrcSpan
!Int -- ^ Line
!Int -- ^ Column
!Int -- ^ Length
deriving Show deriving Show
makeLenses ''MsgEnvelope makeLenses ''MsgEnvelope
@@ -67,11 +68,3 @@ errorMsg s e = MsgEnvelope
, _msgSeverity = SevError , _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
}

78
src/Compiler/Types.hs
View File

@@ -1,78 +0,0 @@
module Compiler.Types
( SrcSpan(..)
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
, Located(..)
, (<<~), (<~>)
-- * Re-exports
, Comonad
, Apply
, Bind
)
where
--------------------------------------------------------------------------------
import Control.Comonad
import Data.Functor.Apply
import Data.Functor.Bind
import Control.Lens hiding ((<<~))
--------------------------------------------------------------------------------
-- | Token wrapped with a span (line, column, absolute, length)
data Located a = Located SrcSpan a
deriving (Show, Functor)
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
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
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 <~>

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

@@ -1,11 +1,11 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TupleSections, PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Errorful module Control.Monad.Errorful
( ErrorfulT(..) ( ErrorfulT
, runErrorfulT
, Errorful , Errorful
, pattern Errorful
, errorful
, runErrorful , runErrorful
, mapErrorful , mapErrorful
, MonadErrorful(..) , MonadErrorful(..)
@@ -13,7 +13,6 @@ module Control.Monad.Errorful
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Monad.Trans import Control.Monad.Trans
import Data.Functor.Identity import Data.Functor.Identity
import Data.Coerce import Data.Coerce
@@ -29,9 +28,6 @@ type Errorful e = ErrorfulT e Identity
pattern Errorful :: (Maybe a, [e]) -> Errorful e a pattern Errorful :: (Maybe a, [e]) -> Errorful e a
pattern Errorful a = ErrorfulT (Identity a) pattern Errorful a = ErrorfulT (Identity a)
errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
errorful = ErrorfulT . pure
runErrorful :: Errorful e a -> (Maybe a, [e]) runErrorful :: Errorful e a -> (Maybe a, [e])
runErrorful m = coerce (runErrorfulT m) runErrorful m = coerce (runErrorfulT m)
@@ -71,13 +67,13 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $
m & mapped . _2 . mapped %~ f m & mapped . _2 . mapped %~ f
-- when microlens-pro drops we can write this as -- when microlens-pro drops we can write this as
-- mapErrorful f = coerced . mapped . _2 . mapped %~ f -- mapErrorful f = coerced . mapped . _2 . mappd %~ f
-- lol -- lol
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- daily dose of n^2 instances -- daily dose of n^2 instances
instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
addWound = lift . addWound addWound = undefined
addFatal = lift . addFatal addFatal = undefined

47
src/Core/Examples.hs
View File

@@ -4,7 +4,12 @@ Description : Core examples (may eventually be unit tests)
-} -}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Core.Examples where module Core.Examples
( fac3
, sumList
, constDivZero
, idCase
) where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Core.Syntax import Core.Syntax
import Core.TH import Core.TH
@@ -142,8 +147,8 @@ simple1 = [coreProg|
caseBool1 :: Program' caseBool1 :: Program'
caseBool1 = [coreProg| caseBool1 = [coreProg|
_if c x y = case c of _if c x y = case c of
{ <1> -> x { 1 -> x
; <0> -> y ; 0 -> y
}; };
false = Pack{0 0}; false = Pack{0 0};
@@ -155,8 +160,8 @@ caseBool1 = [coreProg|
fac3 :: Program' fac3 :: Program'
fac3 = [coreProg| fac3 = [coreProg|
fac n = case (==#) n 0 of fac n = case (==#) n 0 of
{ <1> -> 1 { 1 -> 1
; <0> -> (*#) n (fac ((-#) n 1)) ; 0 -> (*#) n (fac ((-#) n 1))
}; };
main = fac 3; main = fac 3;
@@ -170,8 +175,8 @@ sumList = [coreProg|
cons x y = Pack{1 2} x y; cons x y = Pack{1 2} x y;
list = cons 1 (cons 2 (cons 3 nil)); list = cons 1 (cons 2 (cons 3 nil));
sum l = case l of sum l = case l of
{ <0> -> 0 { 0 -> 0
; <1> x xs -> (+#) x (sum xs) ; 1 x xs -> (+#) x (sum xs)
}; };
main = sum list; main = sum list;
|] |]
@@ -187,36 +192,10 @@ idCase = [coreProg|
id x = x; id x = x;
main = id (case Pack{1 0} of main = id (case Pack{1 0} of
{ <1> -> (+#) 2 3 { 1 -> (+#) 2 3
}) })
|] |]
-- 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
}
|]
namedConsCase :: Program'
namedConsCase = [coreProg|
{-# PackData Nil 0 0 #-}
{-# PackData Cons 1 2 #-}
Nil = Pack{0 0};
Cons = Pack{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 Name
-- corePrelude = Module (Just ("Prelude", [])) $ -- corePrelude = Module (Just ("Prelude", [])) $
-- -- non-primitive defs -- -- non-primitive defs

14
src/Core/HindleyMilner.hs
View File

@@ -55,14 +55,11 @@ instance IsRlpcError TypeError where
liftRlpcError = \case liftRlpcError = \case
-- todo: use anti-parser instead of show -- todo: use anti-parser instead of show
TyErrCouldNotUnify t u -> Text TyErrCouldNotUnify t u -> Text
[ T.pack $ printf "Could not match type `%s` with `%s`." [ T.pack $ printf "Could not match type `%s' with `%s'."
(show t) (show u) (show t) (show u)
, "Expected: " <> tshow t , "Expected: " <> tshow t
, "Got: " <> tshow u , "Got: " <> tshow u
] ]
TyErrUntypedVariable n -> Text
[ "Untyped (likely undefined) variable `" <> n <> "`"
]
TyErrRecursiveType t x -> Text TyErrRecursiveType t x -> Text
[ T.pack $ printf "recursive type error lol" [ T.pack $ printf "recursive type error lol"
] ]
@@ -105,7 +102,7 @@ checkCoreProg p = scDefs
where scname = sc ^. _lhs._1 where scname = sc ^. _lhs._1
-- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks. -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
checkCoreProgR :: (Applicative m) => Program' -> RLPCT m Program' checkCoreProgR :: Program' -> RLPC Program'
checkCoreProgR p = undefined checkCoreProgR p = undefined
{-# WARNING checkCoreProgR "unimpl" #-} {-# WARNING checkCoreProgR "unimpl" #-}
@@ -160,12 +157,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
Let Rec bs e -> do Let Rec bs e -> do
g' <- buildLetrecContext g bs g' <- buildLetrecContext g bs
go g' e 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 -- TODO lambda, case
buildLetrecContext :: Context' -> [Binding'] buildLetrecContext :: Context' -> [Binding']

16
src/Core/Lex.x
View File

@@ -20,11 +20,9 @@ import Debug.Trace
import Data.Text (Text) import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Functor.Identity
import Core.Syntax import Core.Syntax
import Compiler.RLPC import Compiler.RLPC
-- TODO: unify Located definitions import Compiler.RlpcError
import Compiler.RlpcError hiding (Located(..))
import Lens.Micro import Lens.Micro
import Lens.Micro.TH import Lens.Micro.TH
} }
@@ -67,8 +65,6 @@ $white_no_nl = $white # $nl
@decimal = $digit+ @decimal = $digit+
@alttag = "<" $digit+ ">"
rlp :- rlp :-
<0> <0>
@@ -96,8 +92,6 @@ rlp :-
"=" { constTok TokenEquals } "=" { constTok TokenEquals }
"->" { constTok TokenArrow } "->" { constTok TokenArrow }
@alttag { lexWith ( TokenAltTag . read @Int . T.unpack
. T.drop 1 . T.init ) }
@varname { lexWith TokenVarName } @varname { lexWith TokenVarName }
@conname { lexWith TokenConName } @conname { lexWith TokenConName }
@varsym { lexWith TokenVarSym } @varsym { lexWith TokenVarSym }
@@ -141,7 +135,6 @@ data CoreToken = TokenLet
| TokenConName Name | TokenConName Name
| TokenVarSym Name | TokenVarSym Name
| TokenConSym Name | TokenConSym Name
| TokenAltTag Tag
| TokenEquals | TokenEquals
| TokenLParen | TokenLParen
| TokenRParen | TokenRParen
@@ -181,11 +174,8 @@ lexCore s = case m of
where where
m = runAlex s lexStream m = runAlex s lexStream
lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken] lexCoreR :: Text -> RLPC [Located CoreToken]
lexCoreR = hoistRlpcT generalise . lexCore lexCoreR = 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 -- | @lexCore@, but the tokens are stripped of location info. Useful for
-- debugging -- debugging

52
src/Core/Parse.y
View File

@@ -3,7 +3,7 @@
Module : Core.Parse Module : Core.Parse
Description : Parser for the Core language Description : Parser for the Core language
-} -}
{-# LANGUAGE OverloadedStrings, ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-}
module Core.Parse module Core.Parse
( parseCore ( parseCore
, parseCoreExpr , parseCoreExpr
@@ -17,17 +17,13 @@ module Core.Parse
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import Data.Foldable (foldl') import Data.Foldable (foldl')
import Data.Functor.Identity
import Core.Syntax import Core.Syntax
import Core.Lex import Core.Lex
import Compiler.RLPC import Compiler.RLPC
import Control.Monad
import Lens.Micro import Lens.Micro
import Data.Default.Class (def) import Data.Default.Class (def)
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.List.Extra
import Data.Text.IO qualified as TIO import Data.Text.IO qualified as TIO
import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import Data.HashMap.Strict qualified as H import Data.HashMap.Strict qualified as H
} }
@@ -53,7 +49,6 @@ import Data.HashMap.Strict qualified as H
varsym { Located _ _ _ (TokenVarSym $$) } varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) } conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) } consym { Located _ _ _ (TokenConSym $$) }
alttag { Located _ _ _ (TokenAltTag $$) }
word { Located _ _ _ (TokenWord $$) } word { Located _ _ _ (TokenWord $$) }
'λ' { Located _ _ _ TokenLambda } 'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow } '->' { Located _ _ _ TokenArrow }
@@ -87,15 +82,6 @@ Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
| ScTypeSig OptSemi { singletonTypeSig $1 } | ScTypeSig OptSemi { singletonTypeSig $1 }
| ScDef ';' Program { insScDef $1 $3 } | ScDef ';' Program { insScDef $1 $3 }
| ScDef OptSemi { singletonScDef $1 } | 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 :: { () }
OptSemi : ';' { () } OptSemi : ';' { () }
@@ -108,6 +94,7 @@ ScDefs :: { [ScDef Name] }
ScDefs : ScDef ';' ScDefs { $1 : $3 } ScDefs : ScDef ';' ScDefs { $1 : $3 }
| ScDef ';' { [$1] } | ScDef ';' { [$1] }
| ScDef { [$1] } | ScDef { [$1] }
| {- epsilon -} { [] }
ScDef :: { ScDef Name } ScDef :: { ScDef Name }
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
@@ -162,15 +149,22 @@ Alters : Alter ';' Alters { $1 : $3 }
| Alter { [$1] } | Alter { [$1] }
Alter :: { Alter Name } Alter :: { Alter Name }
Alter : alttag ParList '->' Expr { Alter (AltTag $1) $2 $4 } Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
| Con ParList '->' Expr { Alter (AltData $1) $2 $4 }
Expr1 :: { Expr Name } Expr1 :: { Expr Name }
Expr1 : litint { Lit $ IntL $1 } Expr1 : litint { Lit $ IntL $1 }
| Id { Var $1 } | Id { Var $1 }
| PackCon { $1 } | PackCon { $1 }
| ExprPragma { $1 }
| '(' Expr ')' { $2 } | '(' Expr ')' { $2 }
ExprPragma :: { Expr Name }
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
Words :: { [String] }
Words : word Words { T.unpack $1 : $2 }
| word { [T.unpack $1] }
PackCon :: { Expr Name } PackCon :: { Expr Name }
PackCon : pack '{' litint litint '}' { Con $3 $4 } PackCon : pack '{' litint litint '}' { Con $3 $4 }
@@ -226,16 +220,8 @@ insScDef sc = programScDefs %~ (sc:)
singletonScDef :: (Hashable b) => ScDef b -> Program b singletonScDef :: (Hashable b) => ScDef b -> Program b
singletonScDef sc = insScDef sc mempty singletonScDef sc = insScDef sc mempty
parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program' parseCoreProgR :: [Located CoreToken] -> RLPC Program'
parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg) parseCoreProgR = parseCoreProg
where
generalise :: forall a. Identity a -> m a
generalise (Identity a) = pure a
ddumpast :: Program' -> RLPCT m Program'
ddumpast p = do
addDebugMsg "dump-ast" . show $ p
pure p
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
happyBind m k = m >>= k happyBind m k = m >>= k
@@ -243,17 +229,5 @@ happyBind m k = m >>= k
happyPure :: a -> RLPC a happyPure :: a -> RLPC a
happyPure a = pure 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
} }

45
src/Core/Syntax.hs
View File

@@ -5,14 +5,8 @@ Description : Core ASTs and the like
{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DerivingStrategies, DerivingVia #-}
-- for recursion-schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
, TemplateHaskell, TypeFamilies #-}
module Core.Syntax module Core.Syntax
( Expr(..) ( Expr(..)
, ExprF(..)
, ExprF'(..)
, Type(..) , Type(..)
, pattern TyInt , pattern TyInt
, Lit(..) , Lit(..)
@@ -30,11 +24,9 @@ module Core.Syntax
, Module(..) , Module(..)
, Program(..) , Program(..)
, Program' , Program'
, Pragma(..)
, unliftScDef , unliftScDef
, programScDefs , programScDefs
, programTypeSigs , programTypeSigs
, programDataTags
, Expr' , Expr'
, ScDef' , ScDef'
, Alter' , Alter'
@@ -48,15 +40,11 @@ import Data.Coerce
import Data.Pretty import Data.Pretty
import Data.List (intersperse) import Data.List (intersperse)
import Data.Function ((&)) import Data.Function ((&))
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.String import Data.String
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H import Data.HashMap.Strict qualified as H
import Data.Hashable import Data.Hashable
import Data.Text qualified as T import Data.Text qualified as T
import Data.Char import Data.Char
import GHC.Generics
-- Lift instances for the Core quasiquoters -- Lift instances for the Core quasiquoters
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Lens.Micro.TH (makeLenses) import Lens.Micro.TH (makeLenses)
@@ -103,7 +91,7 @@ data Binding b = Binding b (Expr b)
deriving instance (Eq b) => Eq (Binding b) deriving instance (Eq b) => Eq (Binding b)
infixl 1 := infixl 1 :=
pattern (:=) :: b -> Expr b -> Binding b pattern (:=) :: b -> (Expr b) -> (Binding b)
pattern k := v = Binding k v pattern k := v = Binding k v
data Alter b = Alter AltCon [b] (Expr b) data Alter b = Alter AltCon [b] (Expr b)
@@ -111,19 +99,16 @@ data Alter b = Alter AltCon [b] (Expr b)
deriving instance (Eq b) => Eq (Alter b) deriving instance (Eq b) => Eq (Alter b)
newtype Pragma = Pragma [T.Text]
data Rec = Rec data Rec = Rec
| NonRec | NonRec
deriving (Show, Read, Eq, Lift) deriving (Show, Read, Eq, Lift)
data AltCon = AltData Name data AltCon = AltData Tag
| AltTag Tag
| AltLit Lit | AltLit Lit
| Default | Default
deriving (Show, Read, Eq, Lift) deriving (Show, Read, Eq, Lift)
newtype Lit = IntL Int data Lit = IntL Int
deriving (Show, Read, Eq, Lift) deriving (Show, Read, Eq, Lift)
type Name = T.Text type Name = T.Text
@@ -140,20 +125,13 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
data Program b = Program data Program b = Program
{ _programScDefs :: [ScDef b] { _programScDefs :: [ScDef b]
, _programTypeSigs :: HashMap b Type , _programTypeSigs :: H.HashMap b Type
-- map constructors to their tag and arity
, _programDataTags :: HashMap b (Tag, Int)
} }
deriving (Show, Lift, Generic) deriving (Show, Lift)
deriving (Semigroup, Monoid)
via Generically (Program b)
makeLenses ''Program makeLenses ''Program
makeBaseFunctor ''Expr
pure [] pure []
type ExprF' = ExprF Name
type Program' = Program Name type Program' = Program Name
type Expr' = Expr Name type Expr' = Expr Name
type ScDef' = ScDef Name type ScDef' = ScDef Name
@@ -170,6 +148,12 @@ instance IsString Type where
| otherwise = TyVar . fromString $ s | otherwise = TyVar . fromString $ s
where (c:_) = s where (c:_) = s
instance (Hashable b) => Semigroup (Program b) where
(<>) = undefined
instance (Hashable b) => Monoid (Program b) where
mempty = Program mempty mempty
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
@@ -201,10 +185,5 @@ instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
_lhs = lens _lhs = lens
(\ (ScDef n as _) -> (n,as)) (\ (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)

26
src/Core/Utils.hs
View File

@@ -1,10 +1,16 @@
-- for recursion schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- for recursion schemes
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module Core.Utils module Core.Utils
( programRhss ( bindersOf
, programGlobals , rhssOf
, isAtomic , isAtomic
-- , insertModule -- , insertModule
, extractProgram , extractProgram
, freeVariables , freeVariables
, ExprF(..)
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -17,11 +23,13 @@ import Lens.Micro
import GHC.Exts (IsList(..)) import GHC.Exts (IsList(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
programGlobals :: Traversal' (Program b) b bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l
programGlobals = programScDefs . each . _lhs . _1 bindersOf bs = fromList $ fmap f bs
where f (k := _) = k
programRhss :: Traversal' (Program b) (Expr b) rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l
programRhss = programScDefs . each . _rhs rhssOf = fromList . fmap f
where f (_ := v) = v
isAtomic :: Expr b -> Bool isAtomic :: Expr b -> Bool
isAtomic (Var _) = True isAtomic (Var _) = True
@@ -39,6 +47,8 @@ extractProgram (Module _ p) = p
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
makeBaseFunctor ''Expr
freeVariables :: Expr' -> Set Name freeVariables :: Expr' -> Set Name
freeVariables = cata go freeVariables = cata go
where where
@@ -47,8 +57,8 @@ freeVariables = cata go
-- TODO: collect free vars in rhss of bs -- TODO: collect free vars in rhss of bs
go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns
where where
es = bs ^.. each . _rhs :: [Expr'] es = rhssOf bs :: [Expr']
ns = S.fromList $ bs ^.. each . _lhs ns = bindersOf bs
-- TODO: this feels a little wrong. maybe a different scheme is -- TODO: this feels a little wrong. maybe a different scheme is
-- appropriate -- appropriate
esFree = foldMap id $ freeVariables <$> es esFree = foldMap id $ freeVariables <$> es

35
src/Core2Core.hs
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Core2Core module Core2Core
( core2core ( core2core
@@ -16,12 +15,11 @@ import Data.Set (Set)
import Data.Set qualified as S import Data.Set qualified as S
import Data.List import Data.List
import Control.Monad.Writer import Control.Monad.Writer
import Control.Monad.State.Lazy import Control.Monad.State
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Data.Text qualified as T import Data.Text qualified as T
import Data.HashMap.Strict (HashMap)
import Numeric (showHex) import Numeric (showHex)
import Lens.Micro.Platform import Lens.Micro
import Core.Syntax import Core.Syntax
import Core.Utils import Core.Utils
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -30,35 +28,22 @@ core2core :: Program' -> Program'
core2core p = undefined core2core p = undefined
gmPrep :: Program' -> Program' gmPrep :: Program' -> Program'
gmPrep p = p & appFloater (floatNonStrictCases globals) gmPrep p = p' & programScDefs %~ (<>caseScs)
& tagData
where where
rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
rhss = programScDefs . each . _rhs
globals = p ^.. programScDefs . each . _lhs . _1 globals = p ^.. programScDefs . each . _lhs . _1
& S.fromList & S.fromList
tagData :: Program' -> Program' -- i kinda don't like that we're calling floatNonStrictCases twice tbh
tagData p = let ?dt = p ^. programDataTags p' = p & rhss %~ fst . runFloater . floatNonStrictCases globals
in p & programRhss %~ cata go where caseScs = (p ^.. rhss)
go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr' <&> snd . runFloater . floatNonStrictCases globals
go (CaseF e as) = Case e (tagAlts <$> as) & mconcat
go x = embed x
tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs 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@ -- | Auxilary type used in @floatNonSrictCases@
type Floater = StateT [Name] (Writer [ScDef']) 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)
runFloater :: Floater a -> (a, [ScDef']) runFloater :: Floater a -> (a, [ScDef'])
runFloater = flip evalStateT ns >>> runWriter runFloater = flip evalStateT ns >>> runWriter
where where

26
src/GM.hs
View File

@@ -8,7 +8,6 @@ Description : The G-Machine
module GM module GM
( hdbgProg ( hdbgProg
, evalProg , evalProg
, evalProgR
, Node(..) , Node(..)
, gmEvalProg , gmEvalProg
, finalStateOf , finalStateOf
@@ -35,7 +34,6 @@ import System.IO (Handle, hPutStrLn)
import Data.String (IsString) import Data.String (IsString)
import Data.Heap import Data.Heap
import Debug.Trace import Debug.Trace
import Compiler.RLPC
import Core2Core import Core2Core
import Core import Core
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -158,21 +156,6 @@ hdbgProg p hio = do
[resAddr] = final ^. gmStack [resAddr] = final ^. gmStack
res = hLookupUnsafe resAddr h 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 :: GmState -> [GmState]
eval st = st : rest eval st = st : rest
where where
@@ -678,8 +661,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileC _ (Con t n) = [PushConstr t n] compileC _ (Con t n) = [PushConstr t n]
compileC _ (Case _ _) = compileC _ (Case _ _) =
error "GM compiler found a non-strict case expression, which should\ error "case expressions may not appear in non-strict contexts :/"
\ have been floated by Core2Core.gmPrep. This is a bug!"
compileC _ _ = error "yet to be implemented!" compileC _ _ = error "yet to be implemented!"
@@ -742,16 +724,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileD g as = fmap (compileA g) as compileD g as = fmap (compileA g) as
compileA :: Env -> Alter' -> (Tag, Code) compileA :: Env -> Alter' -> (Tag, Code)
compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n]) compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
where where
n = length as n = length as
binds = (NameKey <$> as) `zip` [0..] binds = (NameKey <$> as) `zip` [0..]
g' = binds ++ argOffset n g g' = binds ++ argOffset n g
c = compileE g' e 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 :: Env -> Instr -> Expr' -> Code
inlineOp1 g i a = compileE g a <> [i] inlineOp1 g i a = compileE g a <> [i]

77
src/Rlp/Lex.x
View File

@@ -10,9 +10,6 @@ module Rlp.Lex
, lexStream , lexStream
, lexDebug , lexDebug
, lexCont , lexCont
, popLexState
, programInitState
, runP'
) )
where where
import Codec.Binary.UTF8.String (encodeChar) import Codec.Binary.UTF8.String (encodeChar)
@@ -60,7 +57,7 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
|infixr|infixl|infix |infixr|infixl|infix
@reservedop = @reservedop =
"=" | \\ | "->" | "|" | "::" "=" | \\ | "->" | "|"
rlp :- rlp :-
@@ -76,17 +73,6 @@ $white_no_nl+ ;
-- for the definition of `doBol` -- for the definition of `doBol`
<0> \n { beginPush bol } <0> \n { beginPush bol }
<layout>
{
}
-- layout keywords
<0>
{
"let" { constToken TokenLet `thenBeginPush` layout_let }
}
-- scan various identifiers and reserved words. order is important here! -- scan various identifiers and reserved words. order is important here!
<0> <0>
{ {
@@ -124,14 +110,6 @@ $white_no_nl+ ;
() { doBol } () { doBol }
} }
<layout_let>
{
\n { beginPush bol }
"{" { explicitLBrace }
"in" { constToken TokenIn `thenDo` (popLexState *> popLayout) }
() { doLayout }
}
<layout_top> <layout_top>
{ {
\n ; \n ;
@@ -166,12 +144,6 @@ thenBegin act c inp l = do
psLexState . _head .= c psLexState . _head .= c
pure a 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 :: LexerAction a -> Int -> LexerAction a
andBegin act c inp l = do andBegin act c inp l = do
psLexState . _head .= c psLexState . _head .= c
@@ -192,10 +164,10 @@ alexGetByte inp = case inp ^. aiBytes of
-- report the previous char -- report the previous char
& aiPrevChar .~ c & aiPrevChar .~ c
-- update the position -- update the position
& aiPos %~ \ (ln,col,a) -> & aiPos %~ \ (ln,col) ->
if c == '\n' if c == '\n'
then (ln+1, 1, a+1) then (ln+1,1)
else (ln, col+1, a+1) else (ln,col+1)
pure (b, inp') pure (b, inp')
_ -> Just (head bs, inp') _ -> Just (head bs, inp')
@@ -215,19 +187,19 @@ pushLexState :: Int -> P ()
pushLexState n = psLexState %= (n:) pushLexState n = psLexState %= (n:)
readInt :: Text -> Int readInt :: Text -> Int
readInt = T.foldl f 0 where readInt = T.foldr f 0 where
f n c = 10*n + digitToInt c f c n = digitToInt c + 10*n
constToken :: RlpToken -> LexerAction (Located RlpToken) constToken :: RlpToken -> LexerAction (Located RlpToken)
constToken t inp l = do constToken t inp l = do
pos <- use (psInput . aiPos) pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos l) t) pure (Located (pos,l) t)
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken) tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
tokenWith tf inp l = do tokenWith tf inp l = do
pos <- getPos pos <- getPos
let t = tf (T.take l $ inp ^. aiSource) let t = tf (T.take l $ inp ^. aiSource)
pure (Located (spanFromPos pos l) t) pure (Located (pos,l) t)
getPos :: P Position getPos :: P Position
getPos = use (psInput . aiPos) getPos = use (psInput . aiPos)
@@ -235,12 +207,29 @@ getPos = use (psInput . aiPos)
alexEOF :: P (Located RlpToken) alexEOF :: P (Located RlpToken)
alexEOF = do alexEOF = do
inp <- getInput inp <- getInput
pos <- getPos pure (Located undefined TokenEOF)
pure (Located (spanFromPos pos 0) TokenEOF)
initParseState :: Text -> ParseState
initParseState 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 = [layout_top,0]
, _psInput = initAlexInput s
, _psOpTable = mempty
}
initAlexInput :: Text -> AlexInput
initAlexInput s = AlexInput
{ _aiPrevChar = '\0'
, _aiSource = s
, _aiBytes = []
, _aiPos = (1,1)
}
runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
runP' p s = runP p st where runP' p s = runP p st where
st = initParseState [layout_top,0] s st = initParseState s
lexToken :: P (Located RlpToken) lexToken :: P (Located RlpToken)
lexToken = do lexToken = do
@@ -249,7 +238,7 @@ lexToken = do
st <- use id st <- use id
-- traceM $ "st: " <> show st -- traceM $ "st: " <> show st
case alexScan inp c of case alexScan inp c of
AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
AlexSkip inp' l -> do AlexSkip inp' l -> do
psInput .= inp' psInput .= inp'
lexToken lexToken
@@ -285,7 +274,7 @@ indentLevel = do
insertToken :: RlpToken -> P (Located RlpToken) insertToken :: RlpToken -> P (Located RlpToken)
insertToken t = do insertToken t = do
pos <- use (psInput . aiPos) pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos 0) t) pure (Located (pos, 0) t)
popLayout :: P Layout popLayout :: P Layout
popLayout = do popLayout = do
@@ -294,7 +283,7 @@ popLayout = do
psLayoutStack %= (drop 1) psLayoutStack %= (drop 1)
case ctx of case ctx of
Just l -> pure l Just l -> pure l
Nothing -> error "popLayout: layout stack empty! this is a bug." Nothing -> error "uhh"
pushLayout :: Layout -> P () pushLayout :: Layout -> P ()
pushLayout l = do pushLayout l = do
@@ -352,13 +341,9 @@ explicitRBrace inp l = do
doLayout :: LexerAction (Located RlpToken) doLayout :: LexerAction (Located RlpToken)
doLayout _ _ = do doLayout _ _ = do
i <- indentLevel i <- indentLevel
-- traceM $ "doLayout: i: " <> show i
pushLayout (Implicit i) pushLayout (Implicit i)
popLexState popLexState
insertLBrace insertLBrace
programInitState :: Text -> ParseState
programInitState = initParseState [layout_top,0]
} }

191
src/Rlp/Parse.y
View File

@@ -1,51 +1,39 @@
{ {
{-# LANGUAGE LambdaCase, ViewPatterns #-} {-# LANGUAGE LambdaCase #-}
module Rlp.Parse module Rlp.Parse
( parseRlpProg ( parseRlpProg
, parseRlpProgR
, parseRlpExpr
, parseRlpExprR
) )
where where
import Compiler.RlpcError import Compiler.RlpcError
import Compiler.RLPC
import Rlp.Lex import Rlp.Lex
import Rlp.Syntax import Rlp.Syntax
import Rlp.Parse.Types import Rlp.Parse.Types
import Rlp.Parse.Associate import Rlp.Parse.Associate
import Lens.Micro.Platform import Lens.Micro
import Lens.Micro.Mtl
import Lens.Micro.Platform ()
import Data.List.Extra import Data.List.Extra
import Data.Fix import Data.Fix
import Data.Functor.Const 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.Text qualified as T
import Data.Void
} }
%name parseRlpProg StandaloneProgram %name parseRlpProg StandaloneProgram
%name parseRlpExpr StandaloneExpr
%monad { P } %monad { P }
%lexer { lexCont } { Located _ TokenEOF } %lexer { lexCont } { Located _ TokenEOF }
%error { parseError } %error { parseError }
%errorhandlertype explist
%tokentype { Located RlpToken } %tokentype { Located RlpToken }
%token %token
varname { Located _ (TokenVarName _) } varname { Located _ (TokenVarName $$) }
conname { Located _ (TokenConName _) } conname { Located _ (TokenConName $$) }
consym { Located _ (TokenConSym _) } consym { Located _ (TokenConSym $$) }
varsym { Located _ (TokenVarSym _) } varsym { Located _ (TokenVarSym $$) }
data { Located _ TokenData } data { Located _ TokenData }
litint { Located _ (TokenLitInt _) } litint { Located _ (TokenLitInt $$) }
'=' { Located _ TokenEquals } '=' { Located _ TokenEquals }
'|' { Located _ TokenPipe } '|' { Located _ TokenPipe }
'::' { Located _ TokenHasType }
';' { Located _ TokenSemicolon } ';' { Located _ TokenSemicolon }
'(' { Located _ TokenLParen } '(' { Located _ TokenLParen }
')' { Located _ TokenRParen } ')' { Located _ TokenRParen }
@@ -58,22 +46,15 @@ import Data.Void
infixl { Located _ TokenInfixL } infixl { Located _ TokenInfixL }
infixr { Located _ TokenInfixR } infixr { Located _ TokenInfixR }
infix { Located _ TokenInfix } infix { Located _ TokenInfix }
let { Located _ TokenLet }
in { Located _ TokenIn }
%nonassoc '='
%right '->' %right '->'
%right in
%% %%
StandaloneProgram :: { RlpProgram RlpcPs } StandaloneProgram :: { RlpProgram' }
StandaloneProgram : '{' Decls '}' {% mkProgram $2 } StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
| VL DeclsV VR {% mkProgram $2 } | VL DeclsV VR {% mkProgram $2 }
StandaloneExpr :: { RlpExpr RlpcPs }
: VL Expr VR { extract $2 }
VL :: { () } VL :: { () }
VL : vlbrace { () } VL : vlbrace { () }
@@ -81,150 +62,111 @@ VR :: { () }
VR : vrbrace { () } VR : vrbrace { () }
| error { () } | error { () }
Decls :: { [Decl' RlpcPs] } Decls :: { [PartialDecl'] }
Decls : Decl ';' Decls { $1 : $3 } Decls : Decl ';' Decls { $1 : $3 }
| Decl ';' { [$1] } | Decl ';' { [$1] }
| Decl { [$1] } | Decl { [$1] }
DeclsV :: { [Decl' RlpcPs] } DeclsV :: { [PartialDecl'] }
DeclsV : Decl VS Decls { $1 : $3 } DeclsV : Decl VS Decls { $1 : $3 }
| Decl VS { [$1] } | Decl VS { [$1] }
| Decl { [$1] } | Decl { [$1] }
| {- epsilon -} { [] }
VS :: { Located RlpToken } VS :: { Located RlpToken }
VS : ';' { $1 } VS : ';' { $1 }
| vsemi { $1 } | vsemi { $1 }
Decl :: { Decl' RlpcPs } Decl :: { PartialDecl' }
: FunDecl { $1 } : FunDecl { $1 }
| TySigDecl { $1 }
| DataDecl { $1 } | DataDecl { $1 }
| InfixDecl { $1 } | InfixDecl { $1 }
TySigDecl :: { Decl' RlpcPs } InfixDecl :: { PartialDecl' }
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 } : InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
InfixDecl :: { Decl' RlpcPs } InfixWord :: { Assoc }
: InfixWord litint InfixOp { $1 =>> \w -> : infixl { InfixL }
InfixD (extract $1) (extractInt $ extract $2) | infixr { InfixR }
(extract $3) } | infix { Infix }
InfixWord :: { Located Assoc } DataDecl :: { PartialDecl' }
: infixl { $1 \$> InfixL } : data Con TyParams '=' DataCons { DataD $2 $3 $5 }
| infixr { $1 \$> InfixR }
| infix { $1 \$> Infix }
DataDecl :: { Decl' RlpcPs } TyParams :: { [Name] }
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
TyParams :: { [PsName] }
: {- epsilon -} { [] } : {- epsilon -} { [] }
| TyParams varname { $1 `snoc` (extractName . extract $ $2) } | TyParams varname { $1 `snoc` $2 }
DataCons :: { [ConAlt RlpcPs] } DataCons :: { [ConAlt] }
: DataCons '|' DataCon { $1 `snoc` $3 } : DataCons '|' DataCon { $1 `snoc` $3 }
| DataCon { [$1] } | DataCon { [$1] }
DataCon :: { ConAlt RlpcPs } DataCon :: { ConAlt }
: Con Type1s { ConAlt (extract $1) $2 } : Con Type1s { ConAlt $1 $2 }
Type1s :: { [RlpType' RlpcPs] } Type1s :: { [Type] }
: {- epsilon -} { [] } : {- epsilon -} { [] }
| Type1s Type1 { $1 `snoc` $2 } | Type1s Type1 { $1 `snoc` $2 }
Type1 :: { RlpType' RlpcPs } Type1 :: { Type }
: '(' Type ')' { $2 } : '(' Type ')' { $2 }
| conname { fmap ConT (mkPsName $1) } | conname { TyCon $1 }
| varname { fmap VarT (mkPsName $1) } | varname { TyVar $1 }
Type :: { RlpType' RlpcPs } Type :: { Type }
: Type '->' Type { FunT <<~ $1 <~> $3 } : Type '->' Type { $1 :-> $3 }
| Type1 { $1 } | Type1 { $1 }
FunDecl :: { Decl' RlpcPs } FunDecl :: { PartialDecl' }
FunDecl : Var Params '=' Expr { $4 =>> \e -> FunDecl : Var Params '=' Expr { FunD $1 $2 (Const $4) Nothing }
FunD (extract $1) $2 e Nothing }
Params :: { [Pat' RlpcPs] } Params :: { [Pat'] }
Params : {- epsilon -} { [] } Params : {- epsilon -} { [] }
| Params Pat1 { $1 `snoc` $2 } | Params Pat1 { $1 `snoc` $2 }
Pat1 :: { Pat' RlpcPs } Pat1 :: { Pat' }
: Var { fmap VarP $1 } : Var { VarP $1 }
| Lit { LitP <<= $1 } | Lit { LitP $1 }
Expr :: { RlpExpr' RlpcPs } Expr :: { PartialExpr' }
: Expr1 InfixOp Expr { $2 =>> \o -> : Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
OAppE (extract o) $1 $3 }
| Expr1 { $1 } | Expr1 { $1 }
| LetExpr { $1 }
LetExpr :: { RlpExpr' RlpcPs } Expr1 :: { PartialExpr' }
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } : '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 }
| Lit { Fix . E $ LitEF $1 }
| Var { Fix . E $ VarEF $1 }
layout1(p) : '{' layout_list1(';',p) '}' { $2 } -- TODO: happy prefers left-associativity. doing such would require adjusting
| VL layout_list1(VS,p) VR { $2 } -- the code in Rlp.Parse.Associate to expect left-associative input rather than
-- right.
InfixExpr :: { PartialExpr' }
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
layout_list1(sep,p) : p { [$1] } InfixOp :: { Name }
| layout_list1(sep,p) sep p { $1 `snoc` $3 } : consym { $1 }
| varsym { $1 }
Binding :: { Binding' RlpcPs } Lit :: { Lit' }
: Pat1 '=' Expr { PatB <<~ $1 <~> $3 } Lit : litint { IntL $1 }
Expr1 :: { RlpExpr' RlpcPs } Var :: { VarId }
: '(' Expr ')' { $1 .> $2 <. $3 } Var : varname { NameVar $1 }
| Lit { fmap LitE $1 }
| Var { fmap VarE $1 }
InfixOp :: { Located PsName } Con :: { ConId }
: consym { mkPsName $1 } : conname { NameCon $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 }
Con :: { Located PsName }
: conname { mkPsName $1 }
{ {
parseRlpExprR = undefined mkProgram :: [PartialDecl'] -> P RlpProgram'
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st
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 mkProgram ds = do
pt <- use psOpTable pt <- use psOpTable
pure $ RlpProgram (associate pt <$> ds) pure $ RlpProgram (associate pt <$> ds)
parseError :: (Located RlpToken, [String]) -> P a parseError :: Located RlpToken -> P a
parseError ((Located ss t), exp) = addFatal $ parseError (Located ((l,c),s) t) = addFatal $
errorMsg ss (RlpParErrUnexpectedToken t exp) errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs) mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
mkInfixD a p n = do mkInfixD a p n = do
let opl :: Lens' ParseState (Maybe OpInfo) let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n opl = psOpTable . at n
@@ -234,11 +176,6 @@ mkInfixD a p n = do
l = T.length n l = T.length n
Nothing -> pure (Just (a,p)) Nothing -> pure (Just (a,p))
) )
pos <- use (psInput . aiPos) pure $ InfixD a p n
pure $ Located (spanFromPos pos 0) (InfixD a p n)
intOfToken :: Located RlpToken -> Int
intOfToken (Located _ (TokenLitInt n)) = n
} }

87
src/Rlp/Parse/Associate.hs
View File

@@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-} {-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
module Rlp.Parse.Associate module Rlp.Parse.Associate
{-# WARNING "temporarily unimplemented" #-}
( associate ( associate
) )
where where
@@ -14,6 +13,88 @@ import Rlp.Parse.Types
import Rlp.Syntax import Rlp.Syntax
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
associate x y = y associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
{-# WARNING associate "temporarily undefined" #-} associate pt (FunD n as b w) = FunD n as b' w
where b' = let ?pt = pt in completeExpr (getConst b)
associate pt (TySigD ns t) = TySigD ns t
associate pt (DataD n as cs) = DataD n as cs
associate pt (InfixD a p n) = InfixD a p n
completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
completeExpr = cata completePartial
completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
completePartial (E e) = completeRlpExpr e
completePartial p@(B o l r) = completeB (build p)
completePartial (Par e) = completePartial e
completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
completeRlpExpr = embed
completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
completeB p = case build p of
B o l r -> (o' `AppE` l') `AppE` r'
where
-- TODO: how do we know it's symbolic?
o' = VarE (SymVar o)
l' = completeB l
r' = completeB r
Par e -> completeB e
E e -> completeRlpExpr e
build :: (?pt :: OpTable) => PartialE -> PartialE
build e = go id e (rightmost e) where
rightmost :: PartialE -> PartialE
rightmost (B _ _ r) = rightmost r
rightmost p@(E _) = p
rightmost p@(Par _) = p
go :: (?pt :: OpTable)
=> (PartialE -> PartialE)
-> PartialE -> PartialE -> PartialE
go f p@(WithInfo o _ r) = case r of
E _ -> mkHole o (f . f')
Par _ -> mkHole o (f . f')
B _ _ _ -> go (mkHole o (f . f')) r
where f' r' = p & pR .~ r'
go f _ = id
mkHole :: (?pt :: OpTable)
=> OpInfo
-> (PartialE -> PartialE)
-> PartialE
-> PartialE
mkHole _ hole p@(Par _) = hole p
mkHole _ hole p@(E _) = hole p
mkHole (a,d) hole p@(WithInfo (a',d') _ _)
| d' < d = above
| d' > d = below
| d == d' = case (a,a') of
-- left-associative operators of equal precedence are
-- associated left
(InfixL,InfixL) -> above
-- right-associative operators are handled similarly
(InfixR,InfixR) -> below
-- non-associative operators of equal precedence, or equal
-- precedence operators of different associativities are
-- invalid
(_, _) -> error "invalid expression"
where
above = p & pL %~ hole
below = hole p
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))
]

190
src/Rlp/Parse/Types.hs
View File

@@ -2,28 +2,38 @@
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Rlp.Parse.Types module Rlp.Parse.Types
( ( LexerAction
-- * Trees That Grow , MsgEnvelope(..)
RlpcPs , RlpcError(..)
, AlexInput(..)
-- * Parser monad and state , Position(..)
, P(..), ParseState(..), Layout(..), OpTable, OpInfo , RlpToken(..)
, initParseState, initAlexInput , P(..)
, pToErrorful , ParseState(..)
-- ** Lenses , psLayoutStack
, psLayoutStack, psLexState, psInput, psOpTable , psLexState
, psInput
-- * Other parser types , psOpTable
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Layout(..)
, Located(..), PsName , Located(..)
-- ** Lenses , OpTable
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn , OpInfo
, RlpParseError(..)
, (<<~), (<~>) , PartialDecl'
, Partial(..)
-- * Error handling , pL, pR
, MsgEnvelope(..), RlpcError(..), RlpParseError(..) , PartialE
, addFatal, addWound, addFatalHere, addWoundHere , pattern WithInfo
, opInfoOrDef
, PartialExpr'
, aiPrevChar
, aiSource
, aiBytes
, aiPos
, addFatal
, addWound
, addFatalHere
, addWoundHere
) )
where where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@@ -39,47 +49,12 @@ import Data.Functor.Foldable
import Data.Functor.Const import Data.Functor.Const
import Data.Functor.Classes import Data.Functor.Classes
import Data.HashMap.Strict qualified as H import Data.HashMap.Strict qualified as H
import Data.Void
import Data.Word (Word8) import Data.Word (Word8)
import Data.Text qualified as T
import Lens.Micro.TH import Lens.Micro.TH
import Lens.Micro import Lens.Micro
import Rlp.Syntax import Rlp.Syntax
import Compiler.Types
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Phantom type identifying rlpc's parser phase
data RlpcPs
type instance XRec RlpcPs f = Located (f RlpcPs)
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 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 PsName = Text
--------------------------------------------------------------------------------
spanFromPos :: Position -> Int -> SrcSpan
spanFromPos (l,c,a) s = SrcSpan l c a s
{-# INLINE spanFromPos #-}
type LexerAction a = AlexInput -> Int -> P a type LexerAction a = AlexInput -> Int -> P a
data AlexInput = AlexInput data AlexInput = AlexInput
@@ -91,9 +66,8 @@ data AlexInput = AlexInput
deriving Show deriving Show
type Position = type Position =
( Int -- ^ line ( Int -- line
, Int -- ^ column , Int -- column
, Int -- ^ Absolutely
) )
posLine :: Lens' Position Int posLine :: Lens' Position Int
@@ -102,9 +76,6 @@ posLine = _1
posColumn :: Lens' Position Int posColumn :: Lens' Position Int
posColumn = _2 posColumn = _2
posAbsolute :: Lens' Position Int
posAbsolute = _3
data RlpToken data RlpToken
-- literals -- literals
= TokenLitInt Int = TokenLitInt Int
@@ -135,7 +106,7 @@ data RlpToken
| TokenLParen | TokenLParen
| TokenRParen | TokenRParen
-- 'virtual' control symbols, inserted by the lexer without any correlation -- 'virtual' control symbols, inserted by the lexer without any correlation
-- to a specific part of the input -- to a specific symbol
| TokenSemicolonV | TokenSemicolonV
| TokenLBraceV | TokenLBraceV
| TokenRBraceV | TokenRBraceV
@@ -148,11 +119,6 @@ newtype P a = P {
} }
deriving (Functor) 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 instance Applicative P where
pure a = P $ \st -> (st, [], pure a) pure a = P $ \st -> (st, [], pure a)
liftA2 = liftM2 liftA2 = liftM2
@@ -188,6 +154,9 @@ data Layout = Explicit
| Implicit Int | Implicit Int
deriving (Show, Eq) deriving (Show, Eq)
data Located a = Located (Position, Int) a
deriving (Show)
type OpTable = H.HashMap Name OpInfo type OpTable = H.HashMap Name OpInfo
type OpInfo = (Assoc, Int) type OpInfo = (Assoc, Int)
@@ -196,30 +165,53 @@ type OpInfo = (Assoc, Int)
data RlpParseError = RlpParErrOutOfBoundsPrecedence Int data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
| RlpParErrDuplicateInfixD Name | RlpParErrDuplicateInfixD Name
| RlpParErrLexical | RlpParErrLexical
| RlpParErrUnexpectedToken RlpToken [String] | RlpParErrUnexpectedToken
deriving (Show) deriving (Eq, Ord, Show)
instance IsRlpcError RlpParseError where 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
]
where
tshow :: (Show a) => a -> T.Text
tshow = T.pack . show
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
-- absolute psycho shit (partial ASTs)
type PartialDecl' = Decl (Const PartialExpr') Name
data Partial a = E (RlpExprF Name a)
| B Name (Partial a) (Partial a)
| Par (Partial a)
deriving (Show, Functor)
pL :: Traversal' (Partial a) (Partial a)
pL k (B o l r) = (\l' -> B o l' r) <$> k l
pL _ x = pure x
pR :: Traversal' (Partial a) (Partial a)
pR k (B o l r) = (\r' -> B o l r') <$> k r
pR _ x = pure x
type PartialE = Partial RlpExpr'
-- i love you haskell
pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
-- required to satisfy constraint on Fix's show instance
instance Show1 Partial where
liftShowsPrec :: forall a. (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int -> Partial a -> ShowS
liftShowsPrec sp sl p m = case m of
(E e) -> showsUnaryWith lshow "E" p e
(B f a b) -> showsTernaryWith showsPrec lshow lshow "B" p f a b
(Par e) -> showsUnaryWith lshow "Par" p e
where
lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
lshow = liftShowsPrec sp sl
type PartialExpr' = Fix Partial
makeLenses ''AlexInput makeLenses ''AlexInput
makeLenses ''ParseState makeLenses ''ParseState
@@ -230,7 +222,6 @@ addWoundHere l e = P $ \st ->
{ _msgSpan = let pos = psInput . aiPos { _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine) in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn) (st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l l
, _msgDiagnostic = e , _msgDiagnostic = e
, _msgSeverity = SevError , _msgSeverity = SevError
@@ -243,28 +234,9 @@ addFatalHere l e = P $ \st ->
{ _msgSpan = let pos = psInput . aiPos { _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine) in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn) (st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l l
, _msgDiagnostic = e , _msgDiagnostic = e
, _msgSeverity = SevError , _msgSeverity = SevError
} }
in (st, [e'], Nothing) 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)
}

297
src/Rlp/Syntax.hs
View File

@@ -1,36 +1,40 @@
-- recursion-schemes -- recursion-schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
, TemplateHaskell, TypeFamilies #-} -- recursion-schemes
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax module Rlp.Syntax
( ( RlpModule(..)
-- * AST , RlpProgram(..)
RlpProgram(..) , RlpProgram'
, Decl(..), Decl', RlpExpr(..), RlpExpr' , rlpmodName
, Pat(..), Pat' , rlpmodProgram
, Assoc(..) , RlpExpr(..)
, Lit(..), Lit' , RlpExpr'
, RlpType(..), RlpType' , RlpExprF(..)
, RlpExprF'
, Decl(..)
, Decl'
, Bind(..)
, Where
, Where'
, ConAlt(..) , ConAlt(..)
, Binding(..), Binding' , Type(..)
, pattern (:->)
, Assoc(..)
, VarId(..)
, ConId(..)
, Pat(..)
, Pat'
, Lit(..)
, Lit'
, Name
-- * Trees That Grow boilerplate -- TODO: ugh move this somewhere else later
-- ** Extension points , showsTernaryWith
, IdP, XRec, UnXRec(..), MapXRec(..)
-- *** Decl -- * Convenience re-exports
, XFunD, XTySigD, XInfixD, XDataD, XXDeclD , Text
-- *** RlpExpr
, XLetE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
, XParE, XOAppE, XXRlpExprE
-- ** Pattern synonyms
-- *** Decl
, pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
-- *** RlpExpr
, pattern LetE, pattern VarE, pattern LamE, pattern CaseE, pattern IfE
, pattern AppE, pattern LitE, pattern ParE, pattern OAppE
, pattern XRlpExprE
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -39,180 +43,93 @@ import Data.Text qualified as T
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Classes import Data.Functor.Classes
import Data.Kind (Type)
import Lens.Micro import Lens.Micro
import Lens.Micro.TH import Lens.Micro.TH
import Core.Syntax hiding (Lit, Type, Binding, Binding') import Core.Syntax hiding (Lit)
import Core (HasRHS(..), HasLHS(..)) import Core (HasRHS(..), HasLHS(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data RlpModule p = RlpModule data RlpModule b = RlpModule
{ _rlpmodName :: Text { _rlpmodName :: Text
, _rlpmodProgram :: RlpProgram p , _rlpmodProgram :: RlpProgram b
} }
-- | dear god. newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
type PhaseShow p = deriving Show
( Show (XRec p Pat), Show (XRec p RlpExpr)
, Show (XRec p Lit), Show (IdP p)
, Show (XRec p RlpType)
, Show (XRec p Binding)
)
newtype RlpProgram p = RlpProgram [Decl' p] type RlpProgram' = RlpProgram Name
deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p) -- | The @e@ parameter is used for partial results. When parsing an input, we
-- first parse all top-level declarations in order to extract infix[lr]
-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
-- Text@ stores the remaining unparsed function bodies. Once infixities are
-- accounted for, we may complete the parsing task and get a proper @[Decl
-- RlpExpr Name]@.
data RlpType p = FunConT data Decl e b = FunD VarId [Pat b] (e b) (Maybe (Where b))
| FunT (RlpType' p) (RlpType' p) | TySigD [VarId] Type
| AppT (RlpType' p) (RlpType' p) | DataD ConId [Name] [ConAlt]
| VarT (IdP p) | InfixD Assoc Int Name
| ConT (IdP p) deriving Show
type RlpType' p = XRec p RlpType type Decl' e = Decl e Name
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' ()
type Decl' p = XRec p Decl
data Assoc = InfixL data Assoc = InfixL
| InfixR | InfixR
| Infix | Infix
deriving (Show) deriving Show
data ConAlt p = ConAlt (IdP p) [RlpType' p] data ConAlt = ConAlt ConId [Type]
deriving Show
deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p) data RlpExpr b = LetE Rec [Bind b] (RlpExpr b)
| VarE VarId
| ConE ConId
| LamE [Pat b] (RlpExpr b)
| CaseE (RlpExpr b) [(Alt b, Where b)]
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b)
| AppE (RlpExpr b) (RlpExpr b)
| LitE (Lit b)
deriving Show
data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p) type RlpExpr' = RlpExpr Name
| 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)
type family XLetE p type Where b = [Bind b]
type family XVarE p type Where' = [Bind Name]
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 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 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 (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
class UnXRec p where
unXRec :: XRec p f -> f p
class MapXRec p where
mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f'
type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
type family IdP p
type Where p = [Binding p]
-- do we want guards? -- do we want guards?
data Alt p = AltA (Pat' p) (RlpExpr' p) data Alt b = AltA (Pat b) (RlpExpr b)
deriving Show
deriving instance (PhaseShow p) => Show (Alt p) data Bind b = PatB (Pat b) (RlpExpr b)
| FunB VarId [Pat b] (RlpExpr b)
deriving Show
data Binding p = PatB (Pat' p) (RlpExpr' p) data VarId = NameVar Text
| FunB (IdP p) [Pat' p] (RlpExpr' p) | SymVar Text
deriving Show
type Binding' p = XRec p Binding instance IsString VarId where
-- TODO: use symvar if it's an operator
fromString = NameVar . T.pack
deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p) data ConId = NameCon Text
) => Show (Binding p) | SymCon Text
deriving Show
data Pat p = VarP (IdP p) data Pat b = VarP VarId
| LitP (Lit' p) | LitP (Lit b)
| ConP (IdP p) [Pat' p] | ConP ConId [Pat b]
deriving Show
deriving instance (PhaseShow p) => Show (Pat p) type Pat' = Pat Name
type Pat' p = XRec p Pat data Lit b = IntL Int
data Lit p = IntL Int
| CharL Char | CharL Char
| ListL [RlpExpr' p] | ListL [RlpExpr b]
deriving Show
deriving instance (PhaseShow p) => Show (Lit p) type Lit' = Lit Name
type Lit' p = XRec p Lit
-- instance HasLHS Alt Alt Pat Pat where -- instance HasLHS Alt Alt Pat Pat where
-- _lhs = lens -- _lhs = lens
@@ -226,17 +143,33 @@ type Lit' p = XRec p Lit
makeBaseFunctor ''RlpExpr makeBaseFunctor ''RlpExpr
-- showsTernaryWith :: (Int -> x -> ShowS) deriving instance (Show b, Show a) => Show (RlpExprF b a)
-- -> (Int -> y -> ShowS)
-- -> (Int -> z -> ShowS) type RlpExprF' = RlpExprF Name
-- -> String -> Int
-- -> x -> y -> z -- society if derivable Show1
-- -> ShowS instance (Show b) => Show1 (RlpExprF b) where
-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10) liftShowsPrec sp _ p m = case m of
-- $ showString name (LetEF r bs e) -> showsTernaryWith showsPrec showsPrec sp "LetEF" p r bs e
-- . showChar ' ' . sa 11 a (VarEF n) -> showsUnaryWith showsPrec "VarEF" p n
-- . showChar ' ' . sb 11 b (ConEF n) -> showsUnaryWith showsPrec "ConEF" p n
-- . showChar ' ' . sc 11 c (LamEF bs e) -> showsBinaryWith showsPrec sp "LamEF" p bs e
(CaseEF e as) -> showsBinaryWith sp showsPrec "CaseEF" p e as
(IfEF a b c) -> showsTernaryWith sp sp sp "IfEF" p a b c
(AppEF f x) -> showsBinaryWith sp sp "AppEF" p f x
(LitEF l) -> showsUnaryWith showsPrec "LitEF" p l
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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

12
tst/Core/HindleyMilnerSpec.hs
View File

@@ -38,18 +38,6 @@ spec = do
let e = [coreExpr|3|] let e = [coreExpr|3|]
in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft 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' :: Context' -> Expr' -> Either [TypeError] Type
infer' g e = case runErrorful $ infer g e of infer' g e = case runErrorful $ infer g e of
(Just t, _) -> Right t (Just t, _) -> Right t

15
tst/GMSpec.hs
View File

@@ -27,22 +27,15 @@ spec = do
in coreRes `shouldBe` arithRes in coreRes `shouldBe` arithRes
describe "test programs" $ do describe "test programs" $ do
it "fac 3" $ it "fac 3" $ do
resultOf Ex.fac3 `shouldBe` Just (NNum 6) resultOf Ex.fac3 `shouldBe` Just (NNum 6)
it "sum [1,2,3]" $ it "sum [1,2,3]" $ do
resultOf Ex.sumList `shouldBe` Just (NNum 6) resultOf Ex.sumList `shouldBe` Just (NNum 6)
it "k 3 ((/#) 1 0)" $ it "k 3 ((/#) 1 0)" $ do
resultOf Ex.constDivZero `shouldBe` Just (NNum 3) resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
it "id (case ... of { ... })" $ it "id (case ... of { ... })" $ do
resultOf Ex.idCase `shouldBe` Just (NNum 5) 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)