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

Compare commits

base: msyds:bottom-up-hm
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:test-syntax
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

5 Commits
bottom-up- ... test-synta

Author SHA1 Message Date
crumbtoo
a6ff46e2bf this sucks lol 2023-12-29 22:29:04 -07:00
crumbtoo
d3a25742f1 parse/unparse test 2023-12-29 21:27:18 -07:00
crumbtoo
650a4cf22f unparsers 
unparsers
 2023-12-29 20:58:03 -07:00
crumbtoo
baf9d79285 source code congruency 2023-12-29 19:02:37 -07:00
crumbtoo
c7aed71db5 arbitrary source code 2023-12-29 18:43:20 -07:00
87 changed files with 2049 additions and 8895 deletions
Expand all files Collapse all files

25
.ghci
View File

@@ -1,25 +0,0 @@
-- repl extensions
:set -XOverloadedStrings
:set -XQuasiQuotes
--------------------------------------------------------------------------------
-- happy/alex: override :r to rebuild parsers
:set -package process
:{
import System.Exit qualified
import System.Process qualified
_reload_and_make _ = do
p <- System.Process.spawnCommand "make -f Makefile_happysrcs"
r <- System.Process.waitForProcess p
case r of
System.Exit.ExitSuccess -> pure ":reload"
_ -> pure ""
:}
:def! r _reload_and_make
--------------------------------------------------------------------------------

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

30
Makefile_happysrcs
View File

@@ -1,30 +0,0 @@
GHC_VERSION = $(shell ghc --numeric-version)
HAPPY = happy
HAPPY_OPTS = -a -g -c -i/tmp/t.info
ALEX = alex
ALEX_OPTS = -g
SRC = src
CABAL_BUILD = $(shell ./find-build.clj)
all: parsers lexers
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
$(CABAL_BUILD)/Rlp/AltParse.hs
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Rlp/AltParse.hs: $(SRC)/Rlp/AltParse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
$(ALEX) $(ALEX_OPTS) $< -o $@
$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
$(HAPPY) $(HAPPY_OPTS) $< -o $@
$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
$(ALEX) $(ALEX_OPTS) $< -o $@

97
README.md Normal file
View File

@@ -0,0 +1,97 @@
# rl'
`rlp` (ruelang') will be a lazily-evaluated purely-functional language heavily
imitating Haskell.
### Build Info
* rlp is built using [Cabal](https://www.haskell.org/ghcup/)
* rlp's documentation is built using [Sphinx](https://www.sphinx-doc.org/en/master/)
```sh
$ cabal build # Build the rlpc compiler
$ cabal install # Install rlpc to $PATH
$ cabal haddock # Build the API docs w/ Haddock
$ make -C doc html # Build the primary docs w/ Sphinx
# run the test suite
$ cabal test --test-show-details=direct
```
### Use
```sh
# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr
$ rlpc -ddump-eval examples/factorial.hs
# Compile and evaluate t.hs, with evaluation info dumped to t.log
$ rlpc -ddump-eval -l t.log t.hs
# Print the raw structure describing the compiler options and die
# (option parsing still must succeed in order to print)
$ rlpc -ddump-opts t.hs
```
### Potential Features
Listed in order of importance.
- [ ] ADTs
- [ ] First-class functions
- [ ] Higher-kinded types
- [ ] Typeclasses
- [ ] Parametric polymorphism
- [ ] Hindley-Milner type inference
- [ ] Newtype coercion
- [ ] Parallelism
### Milestones
(This list is incomplete.)
- [ ] Backend
- [x] Core language
- [x] AST
- [x] Low-level execution model (TI)
- [x] Arithmetic
- [x] Conditionals
- [x] Structured data
- [x] Garbage collection
- [x] Low-level execution model (GM)
- [x] Arithmetic
- [x] Conditionals
- [x] Structured data
- [x] Garbage Collection
- [ ] Emitter
- [ ] Code-gen (target yet to be decided)
- [ ] Core language emitter
- [ ] Core linter (Type-checker)
- [ ] Core2Core pass
- [x] GM prep
- [x] Non-strict case-floating
- [ ] Let-floating
- [ ] TCO
- [ ] DCE
- [ ] Frontend
- [ ] High-level language
- [ ] AST
- [ ] Lexer
- [ ] Parser
- [ ] Translation to the core language
- [ ] Constraint solver
- [ ] `do`-notation
- [x] CLI
- [ ] Documentation
- [ ] State transition rules
- [ ] How does the evaluation model work?
- [ ] CLI usage
- [ ] Tail call optimisation
- [x] Parsing rlp
- [ ] Tests
- [x] Generic example programs
- [ ] Parser
### December Release Plan
- [ ] Tests
- [ ] Core lexer
- [ ] Core parser
- [ ] Evaluation model
- [ ] Benchmarks
- [ ] Stable Core lexer
- [ ] Stable Core parser
- [ ] Stable evaluation model
- [ ] Garbage Collection
- [ ] Stable documentation for the evaluation model

188
README.org
View File

@@ -1,188 +0,0 @@
#+title: rl'
#+author: Madeleine Sydney Slaga
~rl'~ will be a lazily-evaluated, purely-functional, statically-typed language
heavily imitating Haskell.
* Architecture
[[file:rlpc.drawio.svg]]
* Build Info
- ~rlpc~ is built using [[https://www.haskell.org/ghcup/][Cabal]]
- ~rlpc~'s documentation is built using
[[https://www.sphinx-doc.org/en/master/][Sphinx]]
#+BEGIN_SRC sh
$ cabal build # Build the rlpc compiler
$ cabal install # Install rlpc to $PATH
$ cabal haddock # Build the API docs w/ Haddock
$ make -C doc html # Build the primary docs w/ Sphinx
# run the test suite
$ cabal test --test-show-details=direct
#+END_SRC
* Use
** TLDR
#+begin_src sh
# Compile and evaluate examples/rlp/QuickSort.rl
$ rlpc examples/QuickSort.rl
# Compile and evaluate t.cr, with evaluation info dumped to t.log
$ rlpc -ddump-eval -l t.log t.cr
# Compile and evaluate t.rl, dumping the desugared Core
$ rlpc -ddump-desugared t.rl
# Compile and evaluate t.rl with all compiler messages enabled
$ rlpc -dALL t.rl
#+end_src
** Options
#+begin_src sh
Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG]
[-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
FILES...
#+end_src
Available debug flags include:
- ~-ddump-desugared~: dump Core generated from rl'
- ~-ddump-parsed-core~: dump raw Core AST
- ~-ddump-parsed~: dump raw rl' AST
- ~-ddump-eval~: dump evaluation logs
- ~-dALL~: disable debug message filtering. enables *all* debug messages
* Demos
[TODO: add hmvis video here]
* To-do List
** TODO rlp to core desugaring :feature:
** DONE [#A] HM memoisation prevents shadowing :bug:
CLOSED: [2024-04-04 Thu 12:29]
Example:
#+begin_src haskell
-- >>> runHM' $ infer1 [rlpExpr|let f = \x -> x in f (let f = 2 in f)|]
-- Left [TyErrCouldNotUnify
-- (ConT "Int#")
-- (AppT (AppT FunT (ConT "Int#")) (VarT "$a2"))]
-- >>> :t let f = \x -> x in f (let f = 2 in f)
-- let f = \x -> x in f (let f = 2 in f) :: Int
#+end_src
For the time being, I just disabled the memoisation. This is very, very bad.
*** Closing Remarks
Fixed by entirely rewriting the type inference algorithm :P. Memoisation is
no longer required; the bottom-up inference a la Algorithm M was previously
hacked together using a comonadic extend with a catamorphism, which, for each
node, would fold the entire subtree and memoise the result, which would then
be retrieved when parent nodes attempted to infer children nodes. This sucks!
It's not "bottom-up" at all! I replaced it with a gorgeous hand-rolled
recursion scheme which truly works from the bottom upwards. A bonus
specialisation is that it annotates each node with the result of a
catamorphism from that node downwards via the cofree comonad.
#+begin_src haskell
dendroscribe :: (Functor f, Base t ~ f, Recursive t)
=> (f (Cofree f a) -> a) -> t -> Cofree f a
dendroscribe c (project -> f) = c f' :< f'
where f' = dendroscribe c <$> f
dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
=> (f (Cofree f a) -> m a) -> t -> m (Cofree f a)
dendroscribeM c (project -> f) = do
as <- dendroscribeM c `traverse` f
a <- c as
pure (a :< as)
#+end_src
** DONE README.md -> README.org :docs:
CLOSED: [2024-03-28 Thu 10:44]
** TODO ~case~ inference :feature:
** DONE ADT support in Rlp/HindleyMilner.hs :feature:
CLOSED: [2024-03-28 Thu 11:55]
** DONE whole-program inference (wrap top-level in a ~letrec~) :feature:
CLOSED: [2024-04-04 Thu 12:42]
shadowing issue sucks. i'm going to have to rewrite the whole type inference
system later. and i never learn, so i'm gonna use a chronomorphism :3.
*** Closing Remarks
I don't know how a fucking chronomorphism works. None of the experts can
think of a single example of how to use it. The rewrite uses a bottom-up
recursion scheme I've dubbed ~dendroscribe~.
** TODO user-supplied annotation support in Rlp/HindleyMilner.hs :feature:
** TODO update architecture diagram :docs:
** TODO pattern support; everywhere [0%] :feature:
- [ ] in the type-checker
- [ ] in the desugarer
** TODO G-machine visualiser :docs:
** TODO lambda calculus visualiser :docs:
** TODO hmvis does not reload when redefining expressions :bug:
To recreate:
1. enter
#+begin_src haskell
x = 2
#+end_src
2. hit "type-check"
3. edit source to
#+begin_src haskell
x = \x -> x
#+end_src
4. hit "type-check"
** DONE in Rlp/HindleyMilner.hs, fix ~listenFreshTvNames~ :housekeeping:
CLOSED: [2024-04-04 Thu 13:17]
it /does/ work in its current state, however it captures an unreasonably
excessive amount of names, even for a heuristic.
*** Closing Remarks
Fixed with the proper Algorithm M rewrite. The original purpose of
~listenFreshTvNames~ (tracking monomorphic type variables) has been solved
much more cleanly via the (non-monadic!) ~monomorphise~ function paired with
the new ~ImplicitInstance~ constraint.
** TODO up-to-date examples [0/2] :docs:
- [ ] quicksort (core and rlp)
- [ ] factorial (core and rlp)
* Releases
** +December Release+
- [X] Tests
- [ ] Core lexer
- [ ] Core parser
- [X] Evaluation model
- [ ] Benchmarks
- [X] Stable Core lexer
- [X] Stable Core parser
- [X] Stable evaluation model
- [X] Garbage Collection
- [ ] Stable documentation for the evaluation model
** +February Release Plan+
- [X] Beta rl' to Core
- [X] UX improvements
- [X] Actual compiler errors -- no more unexceptional `error` calls
- [X] Better CLI dump flags
- [X] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
this has been done, but the locational info is not yet used in error messages)
- [X] Compiler architecture diagram
- [X] More examples
** March Release Plan
- [ ] Tests
- [ ] rl' parser
- [ ] Type inference
- [X] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free,
Cofree, etc. rather than boilerplate-heavy type families
- [X] rl' type inference
- [X] Core type checking

26
app/CoreDriver.hs
View File

@@ -1,26 +0,0 @@
module CoreDriver
( driver
)
where
--------------------------------------------------------------------------------
import Compiler.RLPC
import Control.Monad
import Data.Text qualified as T
import Control.Lens.Combinators
import Core.Lex
import Core.Parse
import Core.SystemF
import GM
--------------------------------------------------------------------------------
driver :: RLPCIO ()
driver = forFiles_ $ \f ->
withSource f (lexCoreR >=> parseCoreProgR >=> lintCoreProgR >=> evalProgR)
driverSource :: T.Text -> RLPCIO ()
driverSource = lexCoreR >=> parseCoreProgR
>=> lintCoreProgR >=> evalProgR >=> printRes
where
printRes = liftIO . print . view _1

144
app/Main.hs
View File

@@ -1,10 +1,7 @@
{-# LANGUAGE BlockArguments, LambdaCase #-} {-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Control.Lens hiding (argument)
import Compiler.RLPC import Compiler.RLPC
import Compiler.RlpcError
import Control.Exception import Control.Exception
import Options.Applicative hiding (ParseError) import Options.Applicative hiding (ParseError)
import Control.Monad import Control.Monad
@@ -13,18 +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 Data.Maybe (listToMaybe)
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 Control.Lens.Combinators hiding (argument) import Lens.Micro.Mtl
import CoreDriver qualified
import RlpDriver qualified
import Server qualified
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
optParser :: ParserInfo RLPCOptions optParser :: ParserInfo RLPCOptions
@@ -46,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"
@@ -70,79 +55,96 @@ options = RLPCOptions
\triggering the garbage collector" \triggering the garbage collector"
<> value 50 <> value 50
) )
<*> optional # option languageReader <*> some (argument str $ metavar "FILES...")
( long "language"
<> short 'x'
<> metavar "rlp|core"
<> help "the language to be compiled -- see README"
)
<*> switch
( long "server"
<> short 's'
)
<*> many (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
"rl" -> Just LanguageRlp
"cr" -> 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
if opts ^. rlpcServer (_, es) <- evalRLPCIO opts driver
then Server.server forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
else void $ evalRLPCIO opts dispatch pure ()
dispatch :: RLPCIO () driver :: RLPCIO CompilerError ()
dispatch = getLang >>= \case driver = sequence_
Just LanguageCore -> CoreDriver.driver [ dshowFlags
Just LanguageRlp -> RlpDriver.driver , ddumpAST
Nothing -> addFatal err , ddumpEval
where ]
-- TODO: why didn't i make the srcspan optional LOL
err = errorMsg (SrcSpan 0 0 0 0) $ Text
[ "Could not determine source language from filetype."
, "Possible Solutions:\n\
\ Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
\ Specify a language with `rlpc -x core' or `rlpc -x rlp'"
]
where
getLang = liftA2 (<|>)
(view rlpcLanguage)
-- TODO: we only check the first file lol
((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
dshowFlags :: RLPCIO CompilerError ()
dshowFlags = whenFlag flagDDumpOpts do
ask >>= liftIO . print
driver :: RLPCIO () ddumpAST :: RLPCIO CompilerError ()
driver = undefined 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"
inferLanguage :: FilePath -> Maybe Language ddumpEval :: RLPCIO CompilerError ()
inferLanguage fp ddumpEval = whenFlag flagDDumpEval do
| ".rl" `isSuffixOf` fp = Just LanguageRlp fs <- view rlpcInputFiles
| ".cr" `isSuffixOf` fp = Just LanguageCore forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
| otherwise = Nothing
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)

19
app/RlpDriver.hs
View File

@@ -1,19 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module RlpDriver
( driver
)
where
--------------------------------------------------------------------------------
import Compiler.RLPC
import Control.Monad
import Rlp.Lex
import Rlp.Parse
import Rlp2Core
import GM
--------------------------------------------------------------------------------
driver :: RLPCIO ()
driver = forFiles_ $ \f ->
withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)

115
app/Server.hs
View File

@@ -1,115 +0,0 @@
{-# LANGUAGE LambdaCase, BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
module Server
( server
)
where
--------------------------------------------------------------------------------
import GHC.Generics (Generic, Generically(..))
import Data.Text.Encoding qualified as T
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Pretty hiding (annotate)
import Data.Aeson
import Data.Function
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Concurrent
import Network.WebSockets qualified as WS
import Control.Exception
import GHC.IO
import Control.Lens hiding ((.=))
import Control.Comonad
import Data.Functor.Foldable
import Compiler.RLPC
import Misc.CofreeF
import Rlp.AltSyntax
import Rlp.HindleyMilner
import Rlp.AltParse
--------------------------------------------------------------------------------
server :: IO ()
server = do
T.putStrLn "rlpc server started at 127.0.0.1:9002"
WS.runServer "127.0.0.1" 9002 application
application :: WS.ServerApp
application pending = do
WS.acceptRequest pending >>= talk
data Command = Annotate Text
| PartiallyAnnotate Text
deriving Show
instance FromJSON Command where
parseJSON = withObject "command object" $ \v -> do
cmd :: Text <- v .: "command"
case cmd of
"annotate" -> Annotate <$> v .: "source"
"partially-annotate" -> PartiallyAnnotate <$> v .: "source"
_ -> empty
data Response = Annotated Value
| PartiallyAnnotated Value
deriving (Generic)
deriving (ToJSON)
via Generically Response
talk :: WS.Connection -> IO ()
talk conn = (`catchAny` print) . forever $ do
msg <- WS.receiveData @Text conn
T.putStrLn $ "received: " <> msg
doCommand conn `traverse` decodeStrictText msg
doCommand :: WS.Connection -> Command -> IO ()
doCommand conn c = do
putStr "sending: "
let r = encode . respond $ c
print r
WS.sendTextData conn r
respond :: Command -> Response
respond (Annotate s)
= s & (parseRlpProgR >=> typeCheckRlpProgR)
& fmap (\p -> p ^.. funDs
<&> serialiseSc)
& runRLPCJsonDef
& Annotated
showPartialAnn = undefined
funDs :: Traversal' (Program b a) (b, [Pat b], a)
funDs = programDecls . each . _FunD
serialiseSc :: (PsName, [Pat PsName], Cofree (RlpExprF PsName) (Type PsName))
-> Value
serialiseSc (n,as,e) = object
[ "name" .= n
, "args" .= as
, "body" .= let root = extract e
in serialiseAnnotated (e <&> renamePrettily root)
]
serialiseAnnotated :: Cofree (RlpExprF PsName) (Type PsName)
-> Value
serialiseAnnotated = cata \case
t :<$ e -> object [ "e" .= e, "type" .= rout @Text t ]
runRLPCJsonWithDef :: (a -> Value) -> RLPC a -> Value
runRLPCJsonWithDef f = runRLPCJsonWith f def
runRLPCJsonDef :: (ToJSON a) => RLPC a -> Value
runRLPCJsonDef = runRLPCJsonWith toJSON def
runRLPCJsonWith :: (a -> Value) -> RLPCOptions -> RLPC a -> Value
runRLPCJsonWith f o r = object
[ "errors" .= es
, "result" .= (f <$> ma) ]
where (ma,es) = evalRLPC o r

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

@@ -63,13 +63,54 @@ an assembly target. The goal of our new G-Machine is to compile a *linear
sequence of instructions* which, **when executed**, build up a graph sequence of instructions* which, **when executed**, build up a graph
representing the code. representing the code.
************* **************************
The G-Machine Trees and Vines, in Theory
************* **************************
Rather than instantiating an expression at runtime -- traversing the AST and
building a graph -- we want to compile all expressions at compile-time,
generating a linear sequence of instructions which may be executed to build the
graph.
**************************
Evaluation: Slurping Vines
**************************
WIP.
Laziness
--------
WIP.
* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
****************************
Compilation: Squashing Trees
****************************
WIP.
Notice that we do not keep a (local) environment at run-time. The environment
only exists at compile-time to map local names to stack indices. When compiling
a supercombinator, the arguments are enumerated from zero (the top of the
stack), and passed to :code:`compileR` as an environment.
.. literalinclude:: /../../src/GM.hs .. literalinclude:: /../../src/GM.hs
:dedent: :dedent:
:start-after: -- >> [ref/Instr] :start-after: -- >> [ref/compileSc]
:end-before: -- << [ref/Instr] :end-before: -- << [ref/compileSc]
:caption: src/GM.hs :caption: src/GM.hs
Of course, variables being indexed relative to the top of the stack means that
they will become inaccurate the moment we push or pop the stack a single time.
The way around this is quite simple: simply offset the stack when w
.. literalinclude:: /../../src/GM.hs
:dedent:
:start-after: -- >> [ref/compileC]
:end-before: -- << [ref/compileC]
:caption: src/GM.hs

204
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,10 +60,170 @@ 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?
***********************
We saw that Python, the most notable example of an implicitly sectioned
language, is pretty simple to lex. Why then am I so afraid of Haskell's layouts?
To be frank, I'm far less scared after asking myself this -- however there are
certainly some new complexities that Python needn't concern. Haskell has
implicit line *continuation*: forms written over multiple lines; indentation
styles often seen in Haskell are somewhat esoteric compared to Python's
"s/[{};]//".
.. code-block:: haskell
-- line continuation
something = this is a
single expression
-- an extremely common style found in haskell
data Python = Users
{ are :: Crying
, right :: About
, now :: Sorry
}
-- another formatting oddity
-- note that this is not a single
-- continued line! `look at`,
-- `this`, and `alignment` are all
-- separate expressions!
anotherThing = do look at
this
alignment
But enough fear, lets actually think about implementation. Firstly, some
formality: what do we mean when we say layout? We will define layout as the
rules we apply to an implicitly-sectioned language in order to yield one that is
explicitly-sectioned. We will also define indentation of a lexeme as the column
number of its first character.
Thankfully for us, our entry point is quite clear; layouts only appear after a
select few keywords, (with a minor exception; TODO: elaborate) being :code:`let`
(followed by supercombinators), :code:`where` (followed by supercombinators),
:code:`do` (followed by expressions), and :code:`of` (followed by alternatives)
(TODO: all of these terms need linked glossary entries). In order to manage the
cascade of layout contexts, our lexer will record a stack for which each element
is either :math:`\varnothing`, denoting an explicit layout written with braces
and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out
layout where the start of each item belonging to the layout is indented
:math:`n` columns.
.. code-block:: haskell
-- layout stack: []
module M where -- layout stack: [∅]
f x = let -- layout keyword; remember indentation of next token
y = w * w -- layout stack: [∅, <10>]
w = x + x
-- layout ends here
in do -- layout keyword; next token is a brace!
{ -- layout stack: [∅]
print y;
print x;
}
Finally, we also need the concept of "virtual" brace tokens, which as far as
we're concerned at this moment are exactly like normal brace tokens, except
implicitly inserted by the compiler. With the presented ideas in mind, we may
begin to introduce a small set of informal rules describing the lexer's handling
of layouts, the first being:
1. If a layout keyword is followed by the token '{', push :math:`\varnothing`
onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto
the layout context stack where :math:`n` is the indentation of the token
following the layout keyword. Additionally, the lexer is to insert a virtual
opening brace after the token representing the layout keyword.
Consider the following observations from that previous code sample:
* Function definitions should belong to a layout, each of which may start at
column 1.
* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and
the :code:`do`-expression.
* Semicolons should *terminate* items, rather than *separate* them.
Our current focus is the semicolons. In an implicit layout, items are on
separate lines each aligned with the previous. A naïve implementation would be
to insert the semicolon token when the EOL is reached, but this proves unideal
when you consider the alignment requirement. In our implementation, our lexer
will wait until the first token on a new line is reached, then compare
indentation and insert a semicolon if appropriate. This comparison -- the
nondescript measurement of "more, less, or equal indentation" rather than a
numeric value -- is referred to as *offside* by myself internally and the
Haskell report describing layouts. We informally formalise this rule as follows:
2. When the first token on a line is preceeded only by whitespace, if the
token's first grapheme resides on a column number :math:`m` equal to the
indentation level of the enclosing context -- i.e. the :math:`\langle n
\rangle` on top of the layout stack. Should no such context exist on the
stack, assume :math:`m > n`.
We have an idea of how to begin layouts, delimit the enclosed items, and last
we'll need to end layouts. This is where the distinction between virtual and
non-virtual brace tokens comes into play. The lexer needs only partial concern
towards closing layouts; the complete responsibility is shared with the parser.
This will be elaborated on in the next section. For now, we will be content with
naïvely inserting a virtual closing brace when a token is indented right of the
layout.
3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall
insert a virtual closing brace and pop the layout stack.
This rule covers some cases including the top-level, however, consider
tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis
framework only allows for lexing a single token at a time, we cannot return both
a virtual right-brace and a :code:`in`. Under this model, the lexer may simply
pop the layout stack and return the :code:`in` token. As we'll see in the next
section, as long as the lexer keeps track of its own context (i.e. the stack),
the parser will cope just fine without the virtual end-brace.
Parsing Lonely Braces
*********************
When viewed in the abstract, parsing and tokenising are near-identical tasks yet
the two are very often decomposed into discrete systems with very different
implementations. Lexers operate on streams of text and tokens, while parsers
are typically far less linear, using a parse stack or recursing top-down. A
big reason for this separation is state management: the parser aims to be as
context-free as possible, while the lexer tends to burden the necessary
statefulness. Still, the nature of a stream-oriented lexer makes backtracking
difficult and quite inelegant.
However, simply declaring a parse error to be not an error at all
counterintuitively proves to be an elegant solution our layout problem which
minimises backtracking and state in both the lexer and the parser. Consider the
following definitions found in rlp's BNF:
.. productionlist:: rlp
VOpen : `vopen`
VClose : `vclose` | `error`
A parse error is recovered and treated as a closing brace. Another point of note
in the BNF is the difference between virtual and non-virtual braces (TODO: i
don't like that the BNF is formatted without newlines :/):
.. productionlist:: rlp
LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr
This ensures that non-virtual braces are closed explicitly.
This set of rules is adequete enough to satisfy our basic concerns about line
continations and layout lists. For a more pedantic description of the layout
system, see `chapter 10
<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ of the
2010 Haskell Report, which I heavily referenced here.
References References
---------- ----------
@@ -70,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.

1
doc/src/conf.py
View File

@@ -32,7 +32,6 @@ html_theme = 'alabaster'
imgmath_latex_preamble = r''' imgmath_latex_preamble = r'''
\usepackage{amsmath} \usepackage{amsmath}
\usepackage{tabularray} \usepackage{tabularray}
\usepackage{syntax}
\newcommand{\transrule}[2] \newcommand{\transrule}[2]
{\begin{tblr}{|rrrlc|} {\begin{tblr}{|rrrlc|}

67
doc/src/references/rlp-grammar.rst
View File

@@ -1,67 +0,0 @@
The Complete Syntax of rl'
==========================
WIP.
Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or
more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'.
.. math
:nowrap:
\setlength{\grammarparsep}{20pt plus 1pt minus 1pt}
\setlength{\grammarindent}{12em}
\begin{grammar}
<Decl> ::= <InfixDecl>
\alt <DataDecl>
\alt <TypeSig>
\alt <FunDef>
<InfixDecl> ::= <InfixWord> `litint' <Name>
<InfixWord> ::= `infix'
\alt `infixl'
\alt `infixr'
<DataDecl> ::= `data' `conname' {}
\end{grammar}
.. code-block:: bnf
Decl ::= InfixDecl
| DataDecl
| TypeSig
| FunDef
InfixDecl ::= InfixWord 'litint' Operator
InfixWord ::= 'infix'
| 'infixl'
| 'infixr'
DataDecl ::= 'data' 'conname' {'name'} '=' Data
DataCons ::= 'conname' {Type1} ['|' DataCons]
TypeSig ::= Var '::' Type
FunDef ::= Var {Pat1} '=' Expr
Type ::= Type1 {Type1}
-- note that (->) is right-associative,
-- and extends as far as possible
| Type '->' Type
Type1 ::= '(' Type ')'
| 'conname'
Pat ::= 'conname' Pat1 {Pat1}
| Pat 'consym' Pat
Pat1 ::= Literal
| 'conname'
| '(' Pat ')'
Literal ::= 'litint'
Var ::= 'varname'
| '(' 'varsym' ')'
Con ::= 'conname'
| '(' 'consym' ')'

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}

0
examples/Core/QuickSort.cr
View File

3
examples/Core/constDivZero.cr
View File

@@ -1,3 +0,0 @@
k x y = x;
main = k 3 (/# 1 0);

9
examples/Core/factorial.cr
View File

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

12
examples/Core/sumList.cr
View File

@@ -1,12 +0,0 @@
{-# PackData Nil 0 0 #-}
{-# PackData Cons 1 2 #-}
foldr f z l = case l of
{ Nil -> z
; Cons x xs -> f x (foldr f z xs)
};
list = Cons 1 (Cons 2 (Cons 3 Nil));
main = foldr (+#) 0 list;

3
examples/constDivZero.hs Normal file
View File

@@ -0,0 +1,3 @@
k x y = x;
main = k 3 ((/#) 1 0);

7
examples/factorial.hs Normal file
View File

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

31
examples/rlp/QuickSort.rl
View File

@@ -1,31 +0,0 @@
data List a = Nil | Cons a (List a)
data Bool = False | True
filter :: (a -> Bool) -> List a -> List a
filter p l = case l of
Nil -> Nil
Cons a as ->
case p a of
True -> Cons a (filter p as)
False -> filter p as
append :: List a -> List a -> List a
append p q = case p of
Nil -> q
Cons a as -> Cons a (append as q)
qsort :: List Int# -> List Int#
qsort l = case l of
Nil -> Nil
Cons a as ->
let lesser = filter (>=# a) as
greater = filter (<# a) as
in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
list :: List Int#
list = Cons 9 (Cons 2 (Cons 3 (Cons 2
(Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
main = print# (qsort list)

11
examples/rlp/SumList.rl
View File

@@ -1,11 +0,0 @@
data List a = Nil | Cons a (List a)
foldr :: (a -> b -> b) -> b -> List a -> b
foldr f z l = case l of
Nil -> z
Cons a as -> f a (foldr f z as)
list = Cons 1 (Cons 2 (Cons 3 Nil))
main = print# (foldr (+#) 0 list)

9
examples/sumList.hs Normal file
View File

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

13
find-build.clj
View File

@@ -1,13 +0,0 @@
#!/usr/bin/env bb
(defn die [& msgs]
(binding [*out* *err*]
(run! println msgs))
(System/exit 1))
(let [paths (map str (fs/glob "." "dist-newstyle/build/*/*/rlp-*/build"))
n (count paths)]
(cond (< 1 n) (die ">1 build directories found. run `cabal clean`.")
(< n 1) (die "no build directories found. this shouldn't happen lol")
:else (-> paths first fs/real-path str println)))

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.

118
rlp.cabal
View File

@@ -7,16 +7,14 @@ 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
-- extra-source-files: -- extra-source-files:
tested-with: GHC==9.6.2
common warnings common warnings
-- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds -- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
ghc-options: -fdefer-typed-holes
library library
import: warnings import: warnings
@@ -32,98 +30,54 @@ library
, Core.TH , Core.TH
, Core.HindleyMilner , Core.HindleyMilner
, Control.Monad.Errorful , Control.Monad.Errorful
, Rlp.Syntax
, Rlp.AltSyntax other-modules: Data.Heap
, Rlp.AltParse
, Rlp.HindleyMilner
, Rlp.HindleyMilner.Visual
, Rlp.HindleyMilner.Types
, Rlp.Syntax.Backstage
, Rlp.Syntax.Types
-- , Rlp.Parse.Decls
, Rlp.Parse
, Rlp.Parse.Associate
, Rlp.Lex
, Rlp.Parse.Types
, Rlp.TH
, Compiler.Types
, Data.Heap
, Data.Pretty , Data.Pretty
, Core.Parse , Core.Parse
, Core.Parse.Types
, Core.Lex , Core.Lex
, Core2Core , Core2Core
, Rlp2Core
, Control.Monad.Utils , Control.Monad.Utils
, Misc , RLP.Syntax
, Misc.Lift1
, Misc.CofreeF
, Core.SystemF
build-tool-depends: happy:happy, alex:alex build-tool-depends: happy:happy, alex:alex
-- other-extensions: -- other-extensions:
build-depends: base >=4.17 && <4.21 build-depends: base ^>=4.18.0.0
, containers
, microlens
, microlens-mtl
, microlens-th
, microlens-platform
, mtl
, template-haskell
-- required for happy -- required for happy
, array >= 0.5.5 && < 0.6 , array
, containers >= 0.6.7 && < 0.7 , data-default-class
, template-haskell >= 2.20.0 && < 2.22 , unordered-containers
, prettyprinter , hashable
, data-default >= 0.7.1 && < 0.8 , pretty
, data-default-class >= 0.1.2 && < 0.2 -- TODO: either learn recursion-schemes, or stop depending
, hashable >= 1.4.3 && < 1.5 -- on it.
, mtl >= 2.3.1 && < 2.4 , recursion-schemes
, transformers , megaparsec
, text >= 2.0.2 && < 2.2 , text
, unordered-containers >= 0.2.20 && < 0.3
, recursion-schemes >= 5.2.2 && < 5.3
, data-fix >= 0.3.2 && < 0.4
, utf8-string >= 1.0.2 && < 1.1
, extra >= 1.7.0 && <2
, semigroupoids >=6.0 && <6.1
, comonad >=5.0.0 && <6
, lens >=5.2.3 && <6.0
, text-ansi >=0.2.0 && <0.4
, effectful-core ^>=2.3.0.0
, deriving-compat ^>=0.6.0
, these >=0.2 && <2.0
, free >=5.2
, bifunctors >=5.2
, aeson >=2.2.1.0 && <2.3.1.0
, lens-aeson
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2021 default-language: GHC2021
default-extensions:
OverloadedStrings
TypeFamilies
LambdaCase
ViewPatterns
DataKinds
DerivingVia
StandaloneDeriving
DerivingStrategies
BlockArguments
executable rlpc executable rlpc
import: warnings import: warnings
main-is: Main.hs main-is: Main.hs
other-modules: RlpDriver -- other-modules:
, CoreDriver -- other-extensions:
, Server 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
, mtl >= 2.3.1 && < 2.4 , microlens
, unordered-containers >= 0.2.20 && < 0.3 , microlens-mtl
, lens >=5.2.3 && <6.0 , mtl
, text >= 2.0.2 && < 2.2 , unordered-containers
, websockets , text
, aeson
, recursion-schemes >= 5.2.2 && < 5.3
, comonad
hs-source-dirs: app hs-source-dirs: app
default-language: GHC2021 default-language: GHC2021
@@ -136,14 +90,20 @@ test-suite rlp-test
hs-source-dirs: tst hs-source-dirs: tst
main-is: Main.hs main-is: Main.hs
build-depends: base ^>=4.18.0.0 build-depends: base ^>=4.18.0.0
, unordered-containers
, rlp , rlp
, QuickCheck , QuickCheck
, hspec ==2.* , hspec ==2.*
, microlens , microlens
, lens >=5.2.3 && <6.0 , text
, pretty
, microlens-platform
other-modules: Arith other-modules: Arith
, GMSpec , GMSpec
, CoreSyntax
, Core.HindleyMilnerSpec , Core.HindleyMilnerSpec
, Compiler.TypesSpec , Core.ParseSpec
build-tool-depends: hspec-discover:hspec-discover build-tool-depends: hspec-discover:hspec-discover

253
rlpc.drawio
View File

@@ -1,253 +0,0 @@
<mxfile host="app.diagrams.net" modified="2024-02-08T07:33:52.268Z" agent="Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:122.0) Gecko/20100101 Firefox/122.0" etag="_2ex2NLQLCDMU70EmKFT" version="23.0.2" type="device">
<diagram name="Page-1" id="ijVUcW-Be2043inOeyM6">
<mxGraphModel dx="1629" dy="2189" grid="1" gridSize="10" guides="1" tooltips="1" connect="1" arrows="1" fold="1" page="1" pageScale="1" pageWidth="827" pageHeight="1169" math="0" shadow="0">
<root>
<mxCell id="0" />
<mxCell id="1" parent="0" />
<mxCell id="l7NxJpuHm0Jx_7flO9iA-64" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;rl&#39; source code&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" parent="1" vertex="1">
<mxGeometry x="10" y="154.92" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-72" value="" style="group;fontFamily=Courier New;" parent="1" vertex="1" connectable="0">
<mxGeometry x="150" y="-60" width="1440" height="780" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-2" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-72" vertex="1">
<mxGeometry width="1440" height="780" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-3" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;RLPC&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry width="1440" height="76.09756097560975" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-56" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry x="38.4" y="68.42" width="431.6" height="221.58" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-57" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Parser&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry width="431.6" height="27.6975" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-58" value="Rlp.Parse&lt;br&gt;&lt;div&gt;(src/Rlp/Parse.y)&lt;/div&gt;" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;whiteSpace=wrap;points=[];strokeColor=#6c8ebf;fillColor=#dae8fc;glass=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="26.980533333333334" y="27.6975" width="371.43053333333336" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-59" value="&lt;div&gt;Rlp.Lex&lt;/div&gt;&lt;div&gt;&lt;br&gt;&lt;/div&gt;&lt;div&gt;(src/Rlp/Lex.x)&lt;br&gt;&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="26.98606666666666" y="147.72" width="170.33402285714286" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-61" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;exitX=0.25;exitY=0;exitDx=0;exitDy=0;" parent="l7NxJpuHm0Jx_7flO9iA-56" edge="1" source="l7NxJpuHm0Jx_7flO9iA-59">
<mxGeometry relative="1" as="geometry">
<mxPoint x="111.49666666666668" y="147.72" as="sourcePoint" />
<mxPoint x="69.26631355932203" y="83.84879190161169" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-62" value="&lt;div&gt;RlpToken&lt;/div&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-61" connectable="0" vertex="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="-33" y="5" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-74" value="&lt;div&gt;Rlp.Parse.Associate&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" vertex="1">
<mxGeometry x="244.26979047619054" y="147.72" width="154.14285714285714" height="55.395" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-75" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-74" edge="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="271.29142857142864" y="175.4175" as="sourcePoint" />
<mxPoint x="394.60571428571427" y="175.4175" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-77" value="&lt;div&gt;RlpProgram&#39; RlpcPs&lt;/div&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-75" vertex="1" connectable="0">
<mxGeometry x="0.0677" y="5" relative="1" as="geometry">
<mxPoint x="39" y="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-3" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.368;exitY=1.014;exitDx=0;exitDy=0;exitPerimeter=0;entryX=0.811;entryY=-0.021;entryDx=0;entryDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-56" source="l7NxJpuHm0Jx_7flO9iA-58" target="l7NxJpuHm0Jx_7flO9iA-59">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="168.70805084745763" y="201.9041131288017" as="sourcePoint" />
<mxPoint x="225.8584745762712" y="152.71439595080588" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-4" value="&lt;p style=&quot;line-height: 60%;&quot;&gt;&lt;font style=&quot;font-size: 7px;&quot;&gt;(lexer &amp;amp; parser threaded w/ CPS)&lt;/font&gt;&lt;/p&gt;" style="text;html=1;strokeColor=none;fillColor=none;align=center;verticalAlign=middle;whiteSpace=wrap;rounded=0;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-56">
<mxGeometry x="88.69745762711862" y="103.52467877281002" width="68.58050847457626" height="29.513830306797498" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-69" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-2" vertex="1">
<mxGeometry x="38.4" y="531.8231578947368" width="431.6" height="230.4557894736842" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-70" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Desugarer&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" parent="l7NxJpuHm0Jx_7flO9iA-69" vertex="1">
<mxGeometry width="431.6" height="46.091157894736845" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-1" value="&lt;div&gt;Rlp2Core&lt;/div&gt;" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-69">
<mxGeometry x="22.122266666666665" y="46.088669843028626" width="387.34440000000006" height="159.17559608494923" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-6" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="904" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-7" value="&lt;font face=&quot;Helvetica&quot;&gt;Evaluation Model&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-8" value="GM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.568013810372213" y="356.90796215152363" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-9" value="TM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.562261652542377" y="263.9548629430177" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-10" value="TIM" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.56226165254238" y="168.9311122835313" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-11" value="STG" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry x="9.56720338983051" y="73.90736162404495" width="167.46559322033886" height="82.98740890928475" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-12" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="68.42" width="281.6" height="314.74" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-13" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;Preprocessing&lt;/font&gt;&lt;/div&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry width="281.5999999999999" height="24.68549019607843" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-15" value="Core2Core" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;verticalAlign=top;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="22.25077720207253" y="49.37098039215686" width="237.09844559585483" height="259.1976470588235" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-16" value="&lt;font face=&quot;Courier New&quot;&gt;tagData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.36994818652857" y="74.0564705882353" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-18" value="&lt;font face=&quot;Courier New&quot;&gt;defineData&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.36994818652857" y="160.45568627450984" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-17" value="&lt;font face=&quot;Courier New&quot;&gt;liftNonStrictCases&lt;/font&gt;" style="rounded=1;whiteSpace=wrap;html=1;fillColor=#d5e8d4;strokeColor=#82b366;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry x="31.369948186528582" y="118.66932274509804" width="218.860103626943" height="37.02823529411765" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-20" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="1240" y="68.42105263157895" width="186.6" height="697.8947368421053" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-21" value="&lt;font face=&quot;Helvetica&quot;&gt;Some target&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-20">
<mxGeometry width="186.6" height="107.07065060420568" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-27" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.019;entryY=0.844;entryDx=0;entryDy=0;entryPerimeter=0;exitX=0.98;exitY=0.066;exitDx=0;exitDy=0;exitPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-1" target="MMc0v0DIyy0xya0iXp__-12">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="450" y="684.2105263157895" as="sourcePoint" />
<mxPoint x="500" y="615.7894736842105" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-28" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-27">
<mxGeometry x="-0.1473" y="1" relative="1" as="geometry">
<mxPoint x="7" y="1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-30" value="" style="endArrow=classic;html=1;rounded=0;entryX=-0.013;entryY=0.321;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;entryPerimeter=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-12" target="MMc0v0DIyy0xya0iXp__-6">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="810" y="588.421052631579" as="sourcePoint" />
<mxPoint x="860" y="520" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-31" value="&lt;font face=&quot;Courier New&quot;&gt;Program&#39;&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-30">
<mxGeometry x="0.0097" y="-1" relative="1" as="geometry">
<mxPoint x="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-32" value="" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-2" source="MMc0v0DIyy0xya0iXp__-6" target="MMc0v0DIyy0xya0iXp__-20">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="810" y="588.421052631579" as="sourcePoint" />
<mxPoint x="860" y="520" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-33" value="&lt;font face=&quot;Courier New&quot;&gt;[Instr]&lt;/font&gt;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-32">
<mxGeometry x="0.0406" y="1" relative="1" as="geometry">
<mxPoint as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-35" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="630" width="281.6" height="131.32" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-36" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Parser&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-41" value="Core.Lex" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry x="10.140518134715029" y="16.369019607843132" width="87.1306390328152" height="106.24535947712415" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-42" value="Core.Parse" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-35">
<mxGeometry x="182.3834196891192" y="16.369019607843146" width="87.1306390328152" height="106.24535947712415" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-43" value="&lt;font face=&quot;Courier New&quot;&gt;CoreToken&lt;/font&gt;" style="endArrow=classic;html=1;rounded=0;entryX=0;entryY=0.5;entryDx=0;entryDy=0;exitX=1;exitY=0.5;exitDx=0;exitDy=0;" edge="1" parent="MMc0v0DIyy0xya0iXp__-35" source="MMc0v0DIyy0xya0iXp__-41" target="MMc0v0DIyy0xya0iXp__-42">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="-72.95336787564769" y="39.35921568627452" as="sourcePoint" />
<mxPoint x="-12.15889464594128" y="1.0422222222222326" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-51" value="" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-2">
<mxGeometry x="530" y="440" width="281.6" height="131.32" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-52" value="&lt;font face=&quot;Helvetica&quot;&gt;Core Type-checker&lt;br&gt;&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-51">
<mxGeometry width="281.59999999999997" height="10.299607843137254" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-46" value="(currently unimplemented)" style="rounded=1;absoluteArcSize=1;html=1;arcSize=10;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
<mxGeometry x="40" y="360" width="431.6" height="90.46" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-47" value="&lt;font face=&quot;Verdana&quot;&gt;Type-checker&lt;/font&gt;" style="html=1;shape=mxgraph.er.anchor;whiteSpace=wrap;fontFamily=Courier New;" vertex="1" parent="MMc0v0DIyy0xya0iXp__-46">
<mxGeometry width="431.6" height="18.092000000000002" as="geometry" />
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-80" value="" style="endArrow=classic;html=1;rounded=0;" parent="l7NxJpuHm0Jx_7flO9iA-72" source="l7NxJpuHm0Jx_7flO9iA-74" target="MMc0v0DIyy0xya0iXp__-46" edge="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="537.6" y="424.2105263157895" as="sourcePoint" />
<mxPoint x="-40" y="490" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-81" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcPs&lt;br&gt;&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" parent="l7NxJpuHm0Jx_7flO9iA-80" connectable="0" vertex="1">
<mxGeometry relative="1" as="geometry">
<mxPoint x="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-49" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-46" target="l7NxJpuHm0Jx_7flO9iA-69">
<mxGeometry relative="1" as="geometry">
<mxPoint x="352" y="282" as="sourcePoint" />
<mxPoint x="295" y="370" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-50" value="&lt;font face=&quot;Courier New&quot;&gt;RlpProgram&#39; RlpcTc&lt;/font&gt;" style="edgeLabel;resizable=0;html=1;align=center;verticalAlign=middle;" connectable="0" vertex="1" parent="MMc0v0DIyy0xya0iXp__-49">
<mxGeometry relative="1" as="geometry">
<mxPoint x="6" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-57" value="Core.HindleyMilner" style="rounded=1;arcSize=10;whiteSpace=wrap;html=1;align=center;fillColor=#dae8fc;strokeColor=#6c8ebf;fontFamily=Courier New;" vertex="1" parent="l7NxJpuHm0Jx_7flO9iA-72">
<mxGeometry x="540" y="460" width="260" height="106.24" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-58" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-42" target="MMc0v0DIyy0xya0iXp__-57">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="530" y="550" as="sourcePoint" />
<mxPoint x="580" y="500" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-59" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-58">
<mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
<mxPoint y="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-60" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="l7NxJpuHm0Jx_7flO9iA-72" source="MMc0v0DIyy0xya0iXp__-57" target="MMc0v0DIyy0xya0iXp__-15">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="741" y="656" as="sourcePoint" />
<mxPoint x="704" y="576" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-61" value="Program&#39;" style="edgeLabel;html=1;align=center;verticalAlign=middle;resizable=0;points=[];fontFamily=Courier New;" vertex="1" connectable="0" parent="MMc0v0DIyy0xya0iXp__-60">
<mxGeometry x="-0.0188" y="-3" relative="1" as="geometry">
<mxPoint y="-1" as="offset" />
</mxGeometry>
</mxCell>
<mxCell id="l7NxJpuHm0Jx_7flO9iA-65" value="" style="endArrow=classic;html=1;rounded=0;fontFamily=Courier New;" parent="1" source="l7NxJpuHm0Jx_7flO9iA-64" target="l7NxJpuHm0Jx_7flO9iA-59" edge="1">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="290" y="400" as="sourcePoint" />
<mxPoint x="340" y="350" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-26" value="&lt;font face=&quot;Helvetica&quot;&gt;Core source code&lt;br&gt;&lt;/font&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
<mxGeometry x="673.7099999999999" y="740" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-29" value="&lt;div&gt;&lt;font face=&quot;Helvetica&quot;&gt;???&lt;/font&gt;&lt;/div&gt;" style="rounded=0;whiteSpace=wrap;html=1;fillColor=#fff2cc;strokeColor=#d6b656;fontFamily=Courier New;" vertex="1" parent="1">
<mxGeometry x="1420" y="730" width="120" height="60" as="geometry" />
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-34" value="" style="endArrow=classic;html=1;rounded=0;exitX=0.5;exitY=0;exitDx=0;exitDy=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-26" target="MMc0v0DIyy0xya0iXp__-41">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="960" y="370" as="sourcePoint" />
<mxPoint x="690" y="570" as="targetPoint" />
</mxGeometry>
</mxCell>
<mxCell id="MMc0v0DIyy0xya0iXp__-62" value="" style="endArrow=classic;html=1;rounded=0;" edge="1" parent="1" source="MMc0v0DIyy0xya0iXp__-20" target="MMc0v0DIyy0xya0iXp__-29">
<mxGeometry width="50" height="50" relative="1" as="geometry">
<mxPoint x="1060" y="650" as="sourcePoint" />
<mxPoint x="1110" y="600" as="targetPoint" />
</mxGeometry>
</mxCell>
</root>
</mxGraphModel>
</diagram>
</mxfile>

4
rlpc.drawio.svg
View File

File diff suppressed because one or more lines are too long
Side by Side

Before

Width:  |  Height:  |  Size: 390 KiB

68
src/Compiler/JustRun.hs
View File

@@ -8,71 +8,41 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
types such as @RLPC@ or @Text@. types such as @RLPC@ or @Text@.
-} -}
module Compiler.JustRun module Compiler.JustRun
( justLexCore ( justLexSrc
, justParseCore , justParseSrc
, justParseRlp , justTypeCheckSrc
, justTypeCheckCore , RlpcError
, justHdbg , Program'
, makeItPretty, makeItPretty'
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Core.Lex import Core.Lex
import Core.Parse import Core.Parse
import Core.HindleyMilner import Core.HindleyMilner
import Core.Syntax import Core.Syntax (Program')
import Compiler.RLPC import Compiler.RLPC
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Control.Monad ((>=>), void) import Control.Monad ((>=>))
import Control.Comonad
import Control.Lens
import Data.Text qualified as T import Data.Text qualified as T
import Data.Function ((&)) import Data.Function ((&))
import System.IO
import GM import GM
import Rlp2Core
import Data.Pretty
import Rlp.AltParse
import Rlp.AltSyntax qualified as Rlp
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
justHdbg :: String -> IO GmState justLexSrc :: String -> Either RlpcError [CoreToken]
justHdbg = undefined justLexSrc s = lexCoreR (T.pack s)
-- justHdbg s = do & fmap (map $ \ (Located _ _ _ t) -> t)
-- p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s) & rlpcToEither
-- withFile "/tmp/t.log" WriteMode $ hdbgProg p
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken] justParseSrc :: String -> Either RlpcError Program'
justLexCore s = lexCoreR (T.pack s) justParseSrc s = parse (T.pack s)
& mapped . each %~ extract
& rlpcToEither
justParseCore :: String -> Either [MsgEnvelope RlpcError] (Program Var)
justParseCore s = parse (T.pack s)
& rlpcToEither
where parse = lexCoreR @Identity >=> parseCoreProgR
justParseRlp :: String
-> Either [MsgEnvelope RlpcError]
(Rlp.Program Name (Rlp.RlpExpr Name))
justParseRlp s = parse (T.pack s)
& rlpcToEither & rlpcToEither
where parse = parseRlpProgR @Identity where parse = lexCoreR >=> parseCoreProgR
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program' justTypeCheckSrc :: String -> Either RlpcError Program'
justTypeCheckCore s = typechk (T.pack s) justTypeCheckSrc s = typechk (T.pack s)
& rlpcToEither & rlpcToEither
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
makeItPretty :: (Out a) => Either e a -> Either e (Doc ann) rlpcToEither :: RLPC e a -> Either e a
makeItPretty = fmap out rlpcToEither = evalRLPC def >>> fmap fst
makeItPretty' :: (Out (WithTerseBinds a)) => Either e a -> Either e (Doc ann)
makeItPretty' = fmap (out . WithTerseBinds)
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
rlpcToEither r = case evalRLPC def r of
(Just a, _) -> Right a
(Nothing, es) -> Left es

297
src/Compiler/RLPC.hs
View File

@@ -10,128 +10,102 @@ errors and the family of RLPC monads.
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
-- only used for mtl instances -- only used for mtl instances
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BlockArguments, ViewPatterns #-} {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
module Compiler.RLPC module Compiler.RLPC
( ( RLPC
-- * Rlpc Monad transformer , RLPCT(..)
RLPCT(RLPCT), , RLPCIO
-- ** Special cases , RLPCOptions(RLPCOptions)
RLPC, RLPCIO , RlpcError(..)
, liftIO , IsRlpcError(..)
-- ** Running , rlpc
, runRLPCT , addFatal
, evalRLPCT, evalRLPCIO, evalRLPC , addWound
-- * Rlpc options , MonadErrorful
, Language(..), Evaluator(..) , Severity(..)
, DebugFlag(..), CompilerFlag(..) , Evaluator(..)
-- ** Lenses , evalRLPCT
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage , evalRLPCIO
, rlpcServer , evalRLPC
-- * Misc. MTL-style functions , addRlpcWound
, liftErrorful, liftEither, liftMaybe, hoistRlpcT , addRlpcFatal
-- * Misc. Rlpc Monad -related types , liftRlpcErrs
, RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..) , rlpcLogFile
, MsgEnvelope(..), Severity(..) , rlpcDebugOpts
, addDebugMsg , rlpcEvaluator
, whenDFlag, whenFFlag , rlpcInputFiles
-- * Misc. Utilities , DebugFlag(..)
, forFiles_, withSource , whenFlag
-- * Convenient re-exports , flagDDumpEval
, addFatal, addWound, def , flagDDumpOpts
, flagDDumpAST
, def
) )
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 GHC.Generics (Generic) import GHC.Generics (Generic)
import Data.Maybe
import Data.Pretty
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 System.IO
import Text.ANSI qualified as Ansi
import Control.Lens
import Data.Text.Lens (packed, unpacked, IsText)
import System.Exit
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
newtype RLPCT m a = RLPCT { -- TODO: fancy errors
runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a newtype RLPCT e m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
} }
deriving ( Functor, Applicative, Monad -- TODO: incorrect ussage of MonadReader. RLPC should have its own
, MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError)) -- environment access functions
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
rlpc :: (IsRlpcError e, Monad m) deriving instance (MonadIO m) => MonadIO (RLPCT e 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 instance MonadTrans (RLPCT e) where
type RLPCIO = RLPCT IO
instance MonadTrans RLPCT where
lift = RLPCT . lift . lift lift = RLPCT . lift . lift
instance (MonadIO m) => MonadIO (RLPCT m) where instance (MonadState s m) => MonadState s (RLPCT e m) where
liftIO = lift . liftIO state = lift . state
evalRLPC :: RLPCOptions type RLPC e = RLPCT e Identity
-> RLPC a
-> (Maybe a, [MsgEnvelope RlpcError]) type RLPCIO e = RLPCT e IO
evalRLPC opt r = runRLPCT r
& flip runReaderT opt
& runErrorful
evalRLPCT :: RLPCOptions evalRLPCT :: RLPCOptions
-> RLPCT m a -> RLPCT e m a
-> m (Maybe a, [MsgEnvelope RlpcError]) -> m (Either e (a, [e]))
evalRLPCT opt r = runRLPCT r evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
& flip runReaderT opt
& runErrorfulT
liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a evalRLPC :: RLPCOptions
liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) -> RLPC e a
-> Either e (a, [e])
evalRLPC o m = coerce $ evalRLPCT o m
liftMaybe :: (Monad m) => Maybe a -> RLPCT m a evalRLPCIO :: (Exception e)
liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, []) => RLPCOptions
-> RLPCIO e a
liftEither :: (Monad m, IsRlpcError e) -> IO (a, [e])
=> Either [e] a -> RLPCT m a evalRLPCIO o m = do
liftEither = RLPCT . lift . ErrorfulT . pure . f where m' <- evalRLPCT o m
f (Left es) = (Nothing, errorMsg s . liftRlpcError <$> es) case m' of
where s = SrcSpan 0 0 0 0 -- TODO: errors
f (Right a) = (Just a, []) Left e -> throwIO e
Right a -> pure a
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 :: Maybe Language
, _rlpcServer :: Bool
, _rlpcInputFiles :: [FilePath] , _rlpcInputFiles :: [FilePath]
} }
deriving Show deriving Show
@@ -139,126 +113,69 @@ data RLPCOptions = RLPCOptions
data Evaluator = EvaluatorGM | EvaluatorTI data Evaluator = EvaluatorGM | EvaluatorTI
deriving Show deriving Show
data Language = LanguageRlp | LanguageCore data Severity = Error
deriving Show | Warning
| Debug
deriving Show
-- temporary until we have a new doc building system
type ErrorDoc = String
instance (Monad m) => MonadErrorful e (RLPCT e m) where
addWound = RLPCT . lift . addWound
addFatal = RLPCT . lift . addFatal
liftRlpcErrs :: (IsRlpcError e, Monad m)
=> RLPCT e m a -> RLPCT RlpcError m a
liftRlpcErrs m = RLPCT . ReaderT $ \r ->
mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcWound = addWound . liftRlpcErr
addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcFatal = addWound . liftRlpcErr
rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
rlpc = RLPCT . ReaderT . const
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
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 = []
, _rlpcServer = False
, _rlpcLanguage = Nothing
} }
-- 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 opt es = case opt ^. rlpcLogFile of
Just lf -> withFile lf WriteMode putter
Nothing -> putter stderr
where
putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es
renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String]
renderRlpcErrs opts = (if don'tBother then id else filter byTag)
>>> fmap prettyRlpcMsg
where
dflags = opts ^. rlpcDFlags
don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags)
byTag :: MsgEnvelope RlpcError -> Bool
byTag (view msgSeverity -> SevDebug t) =
t `S.member` dflags
byTag _ = True
prettyRlpcMsg :: MsgEnvelope RlpcError -> String
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
prettyRlpcMsg m = show $ 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 ann
docRlpcErr msg = vcat [ 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
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

95
src/Compiler/RlpcError.hs
View File

@@ -1,98 +1,15 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module Compiler.RlpcError module Compiler.RlpcError
( IsRlpcError(..) ( RlpcError(..)
, MsgEnvelope(..) , IsRlpcError(..)
, Severity(..)
, RlpcError(..)
, msgSpan
, msgDiagnostic
, msgSeverity
, liftRlpcErrors
, errorMsg
, debugMsg
-- * Located Comonad
, Located(..)
, SrcSpan(..)
-- * Common error messages
, undefinedVariableErr
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Control.Monad.Errorful import Control.Monad.Errorful
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Exts (IsString(..))
import GHC.Generics
import Control.Lens hiding ((.=))
import Compiler.Types
import Data.Aeson
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data MsgEnvelope e = MsgEnvelope data RlpcError = RlpcErr String -- temp
{ _msgSpan :: SrcSpan deriving (Show, Eq)
, _msgDiagnostic :: e
, _msgSeverity :: Severity
}
deriving (Functor, Show)
instance (ToJSON e) => ToJSON (MsgEnvelope e) where class IsRlpcError a where
toJSON msg = object liftRlpcErr :: a -> RlpcError
[ "span" .= _msgSpan msg
, "severity" .= _msgSeverity msg
, "diagnostic" .= _msgDiagnostic msg
]
newtype RlpcError = Text [Text]
deriving (Show, Generic)
deriving (ToJSON)
via Generically [Text]
instance IsString RlpcError where
fromString = Text . pure . T.pack
class IsRlpcError e where
liftRlpcError :: e -> RlpcError
instance IsRlpcError RlpcError where
liftRlpcError = id
data Severity = SevWarning
| SevError
| SevDebug Text -- ^ Tag
deriving (Show, Generic)
deriving (ToJSON)
via Generically Severity
makeLenses ''MsgEnvelope
liftRlpcErrors :: (Functor m, IsRlpcError e)
=> ErrorfulT e m a
-> ErrorfulT RlpcError m a
liftRlpcErrors = mapErrorful liftRlpcError
instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
errorMsg :: SrcSpan -> e -> MsgEnvelope e
errorMsg s e = MsgEnvelope
{ _msgSpan = s
, _msgDiagnostic = e
, _msgSeverity = SevError
}
debugMsg :: Text -> e -> MsgEnvelope e
debugMsg tag e = MsgEnvelope
-- TODO: not pretty, but it is a debug message after all
{ _msgSpan = SrcSpan 0 0 0 0
, _msgDiagnostic = e
, _msgSeverity = SevDebug tag
}
undefinedVariableErr :: Text -> RlpcError
undefinedVariableErr n = Text
[ "Variable not in scope: `" <> n <> "'."
]

234
src/Compiler/Types.hs
View File

@@ -1,234 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
{-# LANGUAGE PatternSynonyms #-}
module Compiler.Types
( SrcSpan(..)
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
, pattern (:<$)
, Located(..)
, HasLocation(..)
, _Located
, nolo, nolo'
, (<~>), (~>), (~~>), (<~~)
, comb2, comb3, comb4
, lochead
-- * Re-exports
, Comonad(extract)
, Apply
, Bind
)
where
--------------------------------------------------------------------------------
import Language.Haskell.TH.Syntax (Lift)
import Control.Comonad
import Control.Comonad.Cofree
import Data.Functor.Apply
import Data.Functor.Bind
import Data.Functor.Compose
import Data.Functor.Foldable
import Data.Semigroup.Foldable
import Data.Fix hiding (cata, ana)
import Data.Kind
import Data.Aeson
import Control.Lens hiding ((<<~), (:<), (.=))
import Data.List.NonEmpty (NonEmpty)
import Data.Function (on)
import Misc.CofreeF
--------------------------------------------------------------------------------
-- | Token wrapped with a span (line, column, absolute, length)
data Located a = Located SrcSpan a
deriving (Show, Lift, Functor)
instance ToJSON SrcSpan where
toJSON (SrcSpan l c a s) = object
[ "line" .= l
, "column" .= c
, "abs" .= a
, "length" .= s]
(<~>) :: a -> b -> SrcSpan
(<~>) = undefined
infixl 5 <~>
(~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
=> a -> b -> b
a ~> b = b & fromSet getSetLocation .~ (a ^. fromGet getSetLocation)
-- (~>) = undefined
infixl 4 ~>
-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
-- => (a -> b) -> a -> b
-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
-- f ~~> (ss :< as) = ss :< f as
(~~>) = undefined
infixl 3 ~~>
-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
-- a <~~ b = a b & location <>~ srcspan b
(<~~) = undefined
infixr 2 <~~
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, Eq, Lift)
_SrcSpan :: Iso' SrcSpan (Int, Int, Int, Int)
_SrcSpan = 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 = _SrcSpan . _1
srcSpanColumn = _SrcSpan . _2
srcSpanAbs = _SrcSpan . _3
srcSpanLen = _SrcSpan . _4
-- | debug tool
nolo :: a -> Located a
nolo = Located (SrcSpan 0 0 0 0)
nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
nolo' as = SrcSpan 0 0 0 0 :< as
instance Semigroup SrcSpan where
-- multiple identities? what are the consequences of this...?
SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
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 + sb - aa)
GT -> max sb (aa + sa - ab)
--------------------------------------------------------------------------------
data GetOrSet = Get | Set | GetSet
class CanGet (k :: GetOrSet)
class CanSet (k :: GetOrSet) where
instance CanGet Get
instance CanGet GetSet
instance CanSet Set
instance CanSet GetSet
data GetSetLens (k :: GetOrSet) s t a b :: Type where
Getter_ :: (s -> a) -> GetSetLens Get s t a b
Setter_ :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
GetterSetter :: (CanGet k', CanSet k')
=> (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
type GetSetLens' k s a = GetSetLens k s s a a
class HasLocation k s | s -> k where
-- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
getSetLocation :: GetSetLens' k s SrcSpan
type family Access (k :: GetOrSet) f where
Access GetSet f = Functor f
Access Set f = Settable f
Access Get f = (Functor f, Contravariant f)
instance HasLocation GetSet SrcSpan where
getSetLocation = GetterSetter id (flip const)
-- location = fromGetSetLens getSetLocation
instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
-- location = fromSet getSetLocation
instance (HasLocation k a) => HasLocation k (Cofree f a) where
getSetLocation = case getSetLocation @_ @a of
Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
GetterSetter sa sbt -> GetterSetter sa' sbt' where
sa' (s :< _) = sa s
sbt' (s :< as) b = sbt s b :< as
location :: (Access k f, Functor f, HasLocation k s)
=> LensLike' f s SrcSpan
location = fromGetSetLens getSetLocation
fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
fromGetSetLens gsl = case gsl of
Getter_ sa -> to sa
Setter_ abst -> setting abst
GetterSetter sa sbt -> lens sa sbt
fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
fromGet (Getter_ sa) = to sa
fromGet (GetterSetter sa _) = to sa
fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
fromSet (Setter_ abst) = setting abst
fromSet (GetterSetter sa sbt) = lens sa sbt
fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
fromGetSet (GetterSetter sa sbt) = lens sa sbt
--------------------------------------------------------------------------------
comb2 :: (Functor f, Semigroup m)
=> (Cofree f m -> Cofree f m -> f (Cofree f m))
-> Cofree f m -> Cofree f m -> Cofree f m
comb2 f a b = ss :< f a b
where ss = a `mextract` b
comb3 :: (Functor f, Semigroup m)
=> (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
-> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
comb3 f a b c = ss :< f a b c
where ss = a `mapply` b `mextract` c
comb4 :: (Functor f, Semigroup m)
=> (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
-> f (Cofree f m))
-> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
comb4 f a b c d = ss :< f a b c d
where ss = a `mapply` b `mapply` c `mextract` d
mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
mextract = (<>) `on` extract
mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
mapply a b = b <&> (<> extract a)
lochead :: Functor f
=> (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
--------------------------------------------------------------------------------
makePrisms ''Located

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

@@ -1,112 +1,73 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TupleSections, PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Errorful module Control.Monad.Errorful
( ErrorfulT(..) ( ErrorfulT
, runErrorfulT
, Errorful , Errorful
, pattern Errorful
, errorful
, runErrorful , runErrorful
, mapErrorful , mapErrors
, hoistErrorfulT
, MonadErrorful(..) , MonadErrorful(..)
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Control.Monad.State.Strict
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Accum
import Control.Monad.Trans import Control.Monad.Trans
import Data.Functor.Identity import Data.Functor.Identity
import Data.Coerce import Data.Coerce
import Data.HashSet (HashSet) import Lens.Micro
import Data.HashSet qualified as H
import Control.Lens
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) } newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
type Errorful e = ErrorfulT e Identity type Errorful e = ErrorfulT e Identity
pattern Errorful :: (Maybe a, [e]) -> Errorful e a pattern Errorful :: (Either e (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 runErrorful :: Errorful e a -> Either e (a, [e])
errorful = ErrorfulT . pure
runErrorful :: Errorful e a -> (Maybe a, [e])
runErrorful m = coerce (runErrorfulT m) runErrorful m = coerce (runErrorfulT m)
class (Applicative m) => MonadErrorful e m | m -> e where class (Applicative m) => MonadErrorful e m | m -> e where
addWound :: e -> m () addWound :: e -> m ()
addFatal :: e -> m a addFatal :: e -> m a
-- | Turn any wounds into fatals
bleedOut :: m a -> m a -- not sure if i want to add this yet...
-- catchWound :: m a -> (e -> m a) -> m a
instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
addWound e = ErrorfulT $ pure (Just (), [e]) addWound e = ErrorfulT $ pure . Right $ ((), [e])
addFatal e = ErrorfulT $ pure (Nothing, [e]) addFatal e = ErrorfulT $ pure . Left $ e
bleedOut m = ErrorfulT $ runErrorfulT m <&> \case
(a, []) -> (a, [])
(_, es) -> (Nothing, es)
instance MonadTrans (ErrorfulT e) where instance MonadTrans (ErrorfulT e) where
lift m = ErrorfulT ((\x -> (Just x,[])) <$> m) lift m = ErrorfulT (Right . (,[]) <$> m)
instance (MonadIO m) => MonadIO (ErrorfulT e m) where instance (MonadIO m) => MonadIO (ErrorfulT e m) where
liftIO = lift . liftIO liftIO = lift . liftIO
instance (Functor m) => Functor (ErrorfulT e m) where instance (Functor m) => Functor (ErrorfulT e m) where
fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f) fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
instance (Applicative m) => Applicative (ErrorfulT e m) where instance (Applicative m) => Applicative (ErrorfulT e m) where
pure a = ErrorfulT . pure $ (Just a, []) pure a = ErrorfulT (pure . Right $ (a, []))
ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where m <*> a = ErrorfulT (m' `apply` a')
apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e]) where
apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2) m' = runErrorfulT m
a' = runErrorfulT a
-- TODO: strict concatenation
apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2))
instance (Monad m) => Monad (ErrorfulT e m) where instance (Monad m) => Monad (ErrorfulT e m) where
ErrorfulT m >>= k = ErrorfulT $ do ErrorfulT m >>= k = ErrorfulT $ do
(a,es) <- m m' <- m
case a of case m' of
Just x -> runErrorfulT (k x) <&> _2 %~ (es<>) Right (a,es) -> runErrorfulT (k a)
Nothing -> pure (Nothing, es) Left e -> pure (Left e)
mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
mapErrorful f (ErrorfulT m) = ErrorfulT $ mapErrors f m = ErrorfulT $ do
m <&> _2 . mapped %~ f x <- runErrorfulT m
case x of
-- when microlens-pro drops we can write this as Left e -> pure . Left $ f e
-- mapErrorful f = coerced . mapped . _2 . mapped %~ f Right (a,es) -> pure . Right $ (a, f <$> es)
-- lol
hoistErrorfulT :: (forall a. m a -> n a) -> ErrorfulT e m a -> ErrorfulT e n a
hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
--------------------------------------------------------------------------------
-- daily dose of n^2 instances
instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
addWound = lift . addWound
addFatal = lift . addFatal
bleedOut = mapReaderT bleedOut
instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where
state = lift . state
instance (Monoid w, Monad m, MonadWriter w m) => MonadWriter w (ErrorfulT e m) where
tell = lift . tell
listen (ErrorfulT m) = ErrorfulT $ listen m <&> \ ((ma,es),w) ->
((,w) <$> ma, es)
pass (ErrorfulT m) = undefined
instance (Monad m, MonadReader r m) => MonadReader r (ErrorfulT e m) where
ask = lift ask
local rr = hoistErrorfulT (local rr)
instance (Monoid w, Monad m, MonadAccum w m)
=> MonadAccum w (ErrorfulT e m) where
accum = lift . accum

16
src/Control/Monad/Utils.hs
View File

@@ -1,15 +1,10 @@
module Control.Monad.Utils module Control.Monad.Utils
( mapAccumLM ( mapAccumLM
, Kendo(..)
, generalise
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Data.Tuple (swap) import Data.Tuple (swap)
import Data.Coerce
import Data.Functor.Identity
import Control.Monad.State import Control.Monad.State
import Control.Monad
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
-- | Monadic variant of @mapAccumL@ -- | Monadic variant of @mapAccumL@
@@ -24,14 +19,3 @@ mapAccumLM k s t = swap <$> runStateT (traverse k' t) s
k' :: a -> StateT s m b k' :: a -> StateT s m b
k' a = StateT $ fmap swap <$> flip k a k' a = StateT $ fmap swap <$> flip k a
newtype Kendo m a = Kendo { appKendo :: a -> m a }
instance (Monad m) => Semigroup (Kendo m a) where
Kendo f <> Kendo g = Kendo (f <=< g)
instance (Monad m) => Monoid (Kendo m a) where
mempty = Kendo pure
generalise :: (Monad m) => Identity a -> m a
generalise (Identity a) = pure a

1
src/Core.hs
View File

@@ -1,5 +1,6 @@
module Core module Core
( module Core.Syntax ( module Core.Syntax
, parseCore
, parseCoreProg , parseCoreProg
, parseCoreExpr , parseCoreExpr
, lexCore , lexCore

63
src/Core/Examples.hs
View File

@@ -4,16 +4,17 @@ 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
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
letRecExample = undefined
{--
letrecExample :: Program' letrecExample :: Program'
letrecExample = [coreProg| letrecExample = [coreProg|
pair x y f = f x y; pair x y f = f x y;
@@ -73,12 +74,12 @@ negExample3 = [coreProg|
arithExample1 :: Program' arithExample1 :: Program'
arithExample1 = [coreProg| arithExample1 = [coreProg|
main = +# 3 (negate# 2); main = (+#) 3 (negate# 2);
|] |]
arithExample2 :: Program' arithExample2 :: Program'
arithExample2 = [coreProg| arithExample2 = [coreProg|
main = negate# (+# 2 (*# 5 3)); main = negate# ((+#) 2 ((*#) 5 3));
|] |]
ifExample1 :: Program' ifExample1 :: Program'
@@ -93,7 +94,7 @@ ifExample2 = [coreProg|
facExample :: Program' facExample :: Program'
facExample = [coreProg| facExample = [coreProg|
fac n = if# (==# n 0) 1 (*# n (fac (-# n 1))); fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1)));
main = fac 3; main = fac 3;
|] |]
@@ -139,21 +140,21 @@ 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};
true = Pack{1 0}; true = Pack{1 0};
main = _if false (+# 2 3) (*# 4 5); main = _if false ((+#) 2 3) ((*#) 4 5);
|] |]
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;
@@ -167,8 +168,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;
|] |]
@@ -176,7 +177,7 @@ sumList = [coreProg|
constDivZero :: Program' constDivZero :: Program'
constDivZero = [coreProg| constDivZero = [coreProg|
k x y = x; k x y = x;
main = k 3 (/# 1 0); main = k 3 ((/#) 1 0);
|] |]
idCase :: Program' idCase :: Program'
@@ -184,34 +185,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 #-}
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
@@ -239,5 +216,3 @@ namedConsCase = [coreProg|
-- , ScDef "Cons" [] $ Con 2 2 -- , ScDef "Cons" [] $ Con 2 2
-- ] -- ]
--}

84
src/Core/HindleyMilner.hs
View File

@@ -3,31 +3,31 @@ Module : Core.HindleyMilner
Description : Hindley-Milner type system Description : Hindley-Milner type system
-} -}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.HindleyMilner module Core.HindleyMilner
( Context' ( Context'
, infer , infer
, check , check
, checkCoreProg , checkCoreProg
, checkCoreProgR , checkCoreProgR
, checkCoreExprR
, TypeError(..) , TypeError(..)
, HMError , HMError
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Lens.Micro
import Lens.Micro.Mtl
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
import Data.Foldable (traverse_)
import Compiler.RLPC import Compiler.RLPC
import Data.Text qualified as T import Control.Monad (foldM, void)
import Control.Monad.Errorful import Control.Monad.Errorful (Errorful, addFatal)
import Control.Monad.State
import Control.Monad.Utils (mapAccumLM)
import Core.Syntax import Core.Syntax
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
infer = undefined
check = undefined
checkCoreProg = undefined
checkCoreProgR = undefined
checkCoreExprR = undefined
-- | Annotated typing context -- I have a feeling we're going to want this in the -- | Annotated typing context -- I have a feeling we're going to want this in the
-- future. -- future.
type Context b = [(b, Type)] type Context b = [(b, Type)]
@@ -35,6 +35,8 @@ type Context b = [(b, Type)]
-- | Unannotated typing context, AKA our beloved Γ. -- | Unannotated typing context, AKA our beloved Γ.
type Context' = Context Name type Context' = Context Name
-- TODO: Errorful monad?
-- | Type error enum. -- | Type error enum.
data TypeError data TypeError
-- | Two types could not be unified -- | Two types could not be unified
@@ -46,14 +48,16 @@ data TypeError
| TyErrMissingTypeSig Name | TyErrMissingTypeSig Name
deriving (Show, Eq) deriving (Show, Eq)
-- TODO:
instance IsRlpcError TypeError where instance IsRlpcError TypeError where
liftRlpcError = undefined liftRlpcErr = RlpcErr . show
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@. -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
type HMError = Errorful TypeError type HMError = Errorful TypeError
{-- -- TODO: better errors. Errorful-esque, with cummulative errors instead of
-- instantly dying.
-- | Assert that an expression unifies with a given type -- | Assert that an expression unifies with a given type
-- --
@@ -72,7 +76,7 @@ check g t1 e = do
-- in the mean time all top-level binders must have a type annotation. -- in the mean time all top-level binders must have a type annotation.
checkCoreProg :: Program' -> HMError () checkCoreProg :: Program' -> HMError ()
checkCoreProg p = scDefs checkCoreProg p = scDefs
& traverse_ k & traverse_ k
where where
scDefs = p ^. programScDefs scDefs = p ^. programScDefs
g = gatherTypeSigs p g = gatherTypeSigs p
@@ -84,17 +88,10 @@ 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 :: forall m. (Monad m) => Program' -> RLPCT m Program' checkCoreProgR :: Program' -> RLPC RlpcError Program'
checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p) checkCoreProgR p = do
$> p liftRlpcErrs . rlpc . checkCoreProg $ p
where pure p
liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
checkCoreExprR :: (Monad m) => Context' -> Expr' -> RLPCT m Expr'
checkCoreExprR g e = (hoistRlpcT generalise . liftE . infer g $ e)
$> e
where
liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
-- | Infer the type of an expression under some context. -- | Infer the type of an expression under some context.
-- --
@@ -143,32 +140,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
Let NonRec bs e -> do Let NonRec bs e -> do
g' <- buildLetContext g bs g' <- buildLetContext g bs
go g' e go g' e
Let Rec bs e -> do -- TODO letrec, lambda, case
g' <- buildLetrecContext g bs
go g' e
Lam bs e -> case bs of
[x] -> do
tx <- uniqueVar
let g' = (x,tx) : g
te <- go g' e
pure (tx :-> te)
-- TODO lambda, case
buildLetrecContext :: Context' -> [Binding']
-> StateT ([Constraint], Int) HMError Context'
buildLetrecContext g bs = do
let f ag (k := _) = do
n <- uniqueVar
pure ((k,n) : ag)
rg <- foldM f g bs
let k ag (k := v) = do
t <- go rg v
pure ((k,t) : ag)
foldM k g bs
-- | augment a context with the inferred types of each binder. the returned
-- context is linearly accumulated, meaning that the context used to infer each binder
-- will include the inferred types of all previous binder
buildLetContext :: Context' -> [Binding'] buildLetContext :: Context' -> [Binding']
-> StateT ([Constraint], Int) HMError Context' -> StateT ([Constraint], Int) HMError Context'
@@ -246,15 +218,3 @@ subst x t (TyVar y) | x == y = t
subst x t (a :-> b) = subst x t a :-> subst x t b subst x t (a :-> b) = subst x t a :-> subst x t b
subst _ _ e = e subst _ _ e = e
--------------------------------------------------------------------------------
demoContext :: Context'
demoContext =
[ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
, ("add", TyInt :-> TyInt :-> TyInt)
, ("==", TyInt :-> TyInt :-> TyCon "Bool")
, ("True", TyCon "Bool")
, ("False", TyCon "Bool")
]
--}

51
src/Core/Lex.x
View File

@@ -20,13 +20,11 @@ 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
import Compiler.Types
-- TODO: unify Located definitions
import Compiler.RlpcError import Compiler.RlpcError
import Control.Lens import Lens.Micro
import Lens.Micro.TH
} }
%wrapper "monad-strict-text" %wrapper "monad-strict-text"
@@ -67,8 +65,6 @@ $white_no_nl = $white # $nl
@decimal = $digit+ @decimal = $digit+
@alttag = "<" $digit+ ">"
rlp :- rlp :-
<0> <0>
@@ -78,7 +74,7 @@ rlp :-
"{" { constTok TokenLBrace } "{" { constTok TokenLBrace }
"}" { constTok TokenRBrace } "}" { constTok TokenRBrace }
";" { constTok TokenSemicolon } ";" { constTok TokenSemicolon }
":" { constTok TokenHasType } "::" { constTok TokenHasType }
"@" { constTok TokenTypeApp } "@" { constTok TokenTypeApp }
"{-#" { constTok TokenLPragma `andBegin` pragma } "{-#" { constTok TokenLPragma `andBegin` pragma }
@@ -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 }
@@ -109,6 +103,8 @@ rlp :-
\n { skip } \n { skip }
} }
-- TODO: negative literals
<pragma> <pragma>
{ {
"#-}" { constTok TokenRPragma `andBegin` 0 } "#-}" { constTok TokenRPragma `andBegin` 0 }
@@ -120,9 +116,11 @@ rlp :-
} }
{ {
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t) constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
data CoreToken = TokenLet data CoreToken = TokenLet
| TokenLetrec | TokenLetrec
@@ -139,7 +137,6 @@ data CoreToken = TokenLet
| TokenConName Name | TokenConName Name
| TokenVarSym Name | TokenVarSym Name
| TokenConSym Name | TokenConSym Name
| TokenAltTag Tag
| TokenEquals | TokenEquals
| TokenLParen | TokenLParen
| TokenRParen | TokenRParen
@@ -169,34 +166,36 @@ data SrcErrorType = SrcErrLexical String
type Lexer = AlexInput -> Int -> Alex (Located CoreToken) type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
lexWith :: (Text -> CoreToken) -> Lexer lexWith :: (Text -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
-- | The main lexer driver. -- | The main lexer driver.
lexCore :: Text -> RLPC [Located CoreToken] lexCore :: Text -> RLPC SrcError [Located CoreToken]
lexCore s = case m of lexCore s = case m of
Left e -> error "core lex error" Left e -> addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = SrcErrLexical e
}
Right ts -> pure ts Right ts -> pure ts
where where
m = runAlex s lexStream m = runAlex s lexStream
lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken] lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
lexCoreR = hoistRlpcT generalise . lexCore lexCoreR = liftRlpcErrs . 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
lexCore' :: Text -> RLPC [CoreToken] lexCore' :: Text -> RLPC SrcError [CoreToken]
lexCore' s = fmap f <$> lexCore s lexCore' s = fmap f <$> lexCore s
where f (Located _ t) = t where f (Located _ _ _ t) = t
lexStream :: Alex [Located CoreToken] lexStream :: Alex [Located CoreToken]
lexStream = do lexStream = do
l <- alexMonadScan l <- alexMonadScan
case l of case l of
Located _ TokenEOF -> pure [l] Located _ _ _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream _ -> (l:) <$> lexStream
data ParseError = ParErrLexical String data ParseError = ParErrLexical String
| ParErrParse | ParErrParse
@@ -204,15 +203,15 @@ data ParseError = ParErrLexical String
-- TODO: -- TODO:
instance IsRlpcError SrcError where instance IsRlpcError SrcError where
liftRlpcError = Text . pure . T.pack . show liftRlpcErr = RlpcErr . show
-- TODO: -- TODO:
instance IsRlpcError ParseError where instance IsRlpcError ParseError where
liftRlpcError = Text . pure . T.pack . show liftRlpcErr = RlpcErr . show
alexEOF :: Alex (Located CoreToken) alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, nolo $ TokenEOF) Right (st, Located y x 0 TokenEOF)
} }

315
src/Core/Lex.x.old Normal file
View File

@@ -0,0 +1,315 @@
{
-- TODO: layout semicolons are not inserted at EOf.
{-# LANGUAGE TemplateHaskell #-}
module Core.Lex
( lexCore
, lexCore'
, CoreToken(..)
, ParseError(..)
, Located(..)
, AlexPosn(..)
)
where
import Data.Char (chr)
import Debug.Trace
import Core.Syntax
import Compiler.RLPC
import Lens.Micro
import Lens.Micro.TH
}
%wrapper "monadUserState"
$whitechar = [ \t\n\r\f\v]
$special = [\(\)\,\;\[\]\{\}]
$digit = 0-9
$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
$unisymbol = [] -- TODO
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
$large = [A-Z \xc0-\xd6 \xd8-\xde]
$small = [a-z \xdf-\xf6 \xf8-\xff \_]
$alpha = [$small $large]
$graphic = [$small $large $symbol $digit $special \:\"\']
$octit = 0-7
$hexit = [0-9 A-F a-f]
$namechar = [$alpha $digit \' \#]
$symchar = [$symbol \:]
$nl = [\n\r]
$white_no_nl = $white # $nl
@reservedid =
case|data|do|import|in|let|letrec|module|of|where
@reservedop =
"=" | \\ | "->"
@varname = $small $namechar*
@conname = $large $namechar*
@varsym = $symbol $symchar*
@consym = \: $symchar*
@decimal = $digit+
rlp :-
-- everywhere: skip whitespace
$white_no_nl+ { skip }
-- TODO: `--` could begin an operator
"--"[^$nl]* { skip }
"--"\-*[^$symbol].* { skip }
"{-" { nestedComment }
-- syntactic symbols
<0>
{
"(" { constTok TokenLParen }
")" { constTok TokenRParen }
"{" { lbrace }
"}" { rbrace }
";" { constTok TokenSemicolon }
"," { constTok TokenComma }
}
-- keywords
-- see commentary on the layout system
<0>
{
"let" { constTok TokenLet `andBegin` layout }
"letrec" { constTok TokenLetrec `andBegin` layout }
"of" { constTok TokenOf `andBegin` layout }
"case" { constTok TokenCase }
"module" { constTok TokenModule }
"in" { letin }
"where" { constTok TokenWhere `andBegin` layout }
}
-- reserved symbols
<0>
{
"=" { constTok TokenEquals }
"->" { constTok TokenArrow }
}
-- identifiers
<0>
{
-- TODO: qualified names
@varname { lexWith TokenVarName }
@conname { lexWith TokenConName }
@varsym { lexWith TokenVarSym }
}
-- literals
<0>
{
@decimal { lexWith (TokenLitInt . read @Int) }
}
<0> \n { begin bol }
<initial>
{
$white { skip }
\n { skip }
() { topLevelOff `andBegin` 0 }
}
<bol>
{
\n { skip }
() { doBol `andBegin` 0 }
}
<layout>
{
$white { skip }
\{ { lbrace `andBegin` 0 }
() { noBrace `andBegin` 0 }
}
{
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
data CoreToken = TokenLet
| TokenLetrec
| TokenIn
| TokenModule
| TokenWhere
| TokenComma
| TokenCase
| TokenOf
| TokenLambda
| TokenArrow
| TokenLitInt Int
| TokenVarName Name
| TokenConName Name
| TokenVarSym Name
| TokenConSym Name
| TokenEquals
| TokenLParen
| TokenRParen
| TokenLBrace
| TokenRBrace
| TokenLBraceV -- virtual brace inserted by layout
| TokenRBraceV -- virtual brace inserted by layout
| TokenIndent Int
| TokenDedent Int
| TokenSemicolon
| TokenEOF
deriving Show
data LayoutContext = Layout Int
| NoLayout
deriving Show
data AlexUserState = AlexUserState
{ _ausContext :: [LayoutContext]
}
ausContext :: Lens' AlexUserState [LayoutContext]
ausContext f (AlexUserState ctx)
= fmap
(\a -> AlexUserState a) (f ctx)
{-# INLINE ausContext #-}
pushContext :: LayoutContext -> Alex ()
pushContext c = do
st <- alexGetUserState
alexSetUserState $ st { _ausContext = c : _ausContext st }
popContext :: Alex ()
popContext = do
st <- alexGetUserState
alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) }
getContext :: Alex [LayoutContext]
getContext = do
st <- alexGetUserState
pure $ _ausContext st
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState []
nestedComment :: Lexer
nestedComment _ _ = undefined
lexStream :: Alex [Located CoreToken]
lexStream = do
l <- alexMonadScan
case l of
Located _ _ _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
-- | The main lexer driver.
lexCore :: String -> RLPC ParseError [Located CoreToken]
lexCore s = case m of
Left e -> addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = ParErrLexical e
}
Right ts -> pure ts
where
m = runAlex s (alexSetStartCode initial *> lexStream)
-- | @lexCore@, but the tokens are stripped of location info. Useful for
-- debugging
lexCore' :: String -> RLPC ParseError [CoreToken]
lexCore' s = fmap f <$> lexCore s
where f (Located _ _ _ t) = t
data ParseError = ParErrLexical String
| ParErrParse
deriving Show
lexWith :: (String -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
lexToken :: Alex (Located CoreToken)
lexToken = alexMonadScan
getSrcCol :: Alex Int
getSrcCol = Alex $ \ st ->
let AlexPn _ _ col = alex_pos st
in Right (st, col)
lbrace :: Lexer
lbrace (AlexPn _ y x,_,_,_) l = do
pushContext NoLayout
pure $ Located y x l TokenLBrace
rbrace :: Lexer
rbrace (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located y x l TokenRBrace
insRBraceV :: AlexPosn -> Alex (Located CoreToken)
insRBraceV (AlexPn _ y x) = do
popContext
pure $ Located y x 0 TokenRBraceV
insSemi :: AlexPosn -> Alex (Located CoreToken)
insSemi (AlexPn _ y x) = do
pure $ Located y x 0 TokenSemicolon
modifyUst :: (AlexUserState -> AlexUserState) -> Alex ()
modifyUst f = do
st <- alexGetUserState
alexSetUserState $ f st
getUst :: Alex AlexUserState
getUst = alexGetUserState
newLayoutContext :: Lexer
newLayoutContext (p,_,_,_) _ = do
undefined
noBrace :: Lexer
noBrace (AlexPn _ y x,_,_,_) l = do
col <- getSrcCol
pushContext (Layout col)
pure $ Located y x l TokenLBraceV
getOffside :: Alex Ordering
getOffside = do
ctx <- getContext
m <- getSrcCol
case ctx of
Layout n : _ -> pure $ m `compare` n
_ -> pure GT
doBol :: Lexer
doBol (p,c,_,s) _ = do
off <- getOffside
case off of
LT -> insRBraceV p
EQ -> insSemi p
_ -> lexToken
letin :: Lexer
letin (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located y x l TokenIn
topLevelOff :: Lexer
topLevelOff = noBrace
alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, Located y x 0 TokenEOF)
}

288
src/Core/Parse.y
View File

@@ -3,267 +3,237 @@
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
( parseCoreExpr ( parseCore
, parseCoreExprR , parseCoreExpr
, parseCoreProg , parseCoreProg
, parseCoreProgR , parseCoreProgR
, module Core.Lex -- temp convenience , module Core.Lex -- temp convenience
, parseTmp
, SrcError , SrcError
, Module
) )
where where
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import Control.Monad.Utils (generalise)
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 Control.Lens hiding (snoc)
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
import Core.Parse.Types
} }
%name parseCore Module
%name parseCoreExpr StandaloneExpr %name parseCoreExpr StandaloneExpr
%name parseCoreProg StandaloneProgram %name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken } %tokentype { Located CoreToken }
%error { parseError } %error { parseError }
%monad { P } %monad { RLPC SrcError }
%token %token
let { Located _ TokenLet } let { Located _ _ _ TokenLet }
letrec { Located _ TokenLetrec } letrec { Located _ _ _ TokenLetrec }
where { Located _ TokenWhere } module { Located _ _ _ TokenModule }
case { Located _ TokenCase } where { Located _ _ _ TokenWhere }
of { Located _ TokenOf } case { Located _ _ _ TokenCase }
pack { Located _ TokenPack } -- temp of { Located _ _ _ TokenOf }
in { Located _ TokenIn } pack { Located _ _ _ TokenPack } -- temp
litint { Located _ (TokenLitInt $$) } in { Located _ _ _ TokenIn }
varname { Located _ (TokenVarName $$) } litint { Located _ _ _ (TokenLitInt $$) }
varsym { Located _ (TokenVarSym $$) } varname { Located _ _ _ (TokenVarName $$) }
conname { Located _ (TokenConName $$) } varsym { Located _ _ _ (TokenVarSym $$) }
consym { Located _ (TokenConSym $$) } conname { Located _ _ _ (TokenConName $$) }
alttag { Located _ (TokenAltTag $$) } consym { Located _ _ _ (TokenConSym $$) }
word { Located _ (TokenWord $$) } word { Located _ _ _ (TokenWord $$) }
'λ' { Located _ TokenLambda } 'λ' { Located _ _ _ TokenLambda }
'->' { Located _ TokenArrow } '->' { Located _ _ _ TokenArrow }
'=' { Located _ TokenEquals } '=' { Located _ _ _ TokenEquals }
'@' { Located _ TokenTypeApp } '@' { Located _ _ _ TokenTypeApp }
'(' { Located _ TokenLParen } '(' { Located _ _ _ TokenLParen }
')' { Located _ TokenRParen } ')' { Located _ _ _ TokenRParen }
'{' { Located _ TokenLBrace } '{' { Located _ _ _ TokenLBrace }
'}' { Located _ TokenRBrace } '}' { Located _ _ _ TokenRBrace }
'{-#' { Located _ TokenLPragma } '{-#' { Located _ _ _ TokenLPragma }
'#-}' { Located _ TokenRPragma } '#-}' { Located _ _ _ TokenRPragma }
';' { Located _ TokenSemicolon } ';' { Located _ _ _ TokenSemicolon }
':' { Located _ TokenHasType } '::' { Located _ _ _ TokenHasType }
eof { Located _ TokenEOF } eof { Located _ _ _ TokenEOF }
%right '->'
%% %%
Module :: { Module Name }
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
| Program Eof { Module Nothing $1 }
Eof :: { () } Eof :: { () }
Eof : eof { () } Eof : eof { () }
| error { () } | error { () }
StandaloneProgram :: { Program Var } StandaloneProgram :: { Program Name }
StandaloneProgram : Program eof { $1 } StandaloneProgram : Program eof { $1 }
| eof { mempty }
Program :: { Program Var } Program :: { Program Name }
: TypedScDef ';' Program { $3 & insTypeSig (fst $1) Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
& insScDef (snd $1) } | ScTypeSig OptSemi { singletonTypeSig $1 }
| TypedScDef OptSemi { mempty & insTypeSig (fst $1) | ScDef ';' Program { insScDef $1 $3 }
& insScDef (snd $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 : ';' { () }
| {- epsilon -} { () } | {- epsilon -} { () }
ScTypeSig :: { (Name, Type) } ScTypeSig :: { (Name, Type) }
ScTypeSig : Id ':' Type { ($1, $3) } ScTypeSig : Var '::' Type { ($1,$3) }
TypedScDef :: { (Var, ScDef Var) } ScDefs :: { [ScDef Name] }
: Id ':' Type ';' Id ParList '=' Expr ScDefs : ScDef ';' ScDefs { $1 : $3 }
{ (MkVar $1 $3, mkTypedScDef $1 $3 $5 $6 $8) } | ScDef ';' { [$1] }
| ScDef { [$1] }
| {- epsilon -} { [] }
-- ScDefs :: { [ScDef PsName] } ScDef :: { ScDef Name }
-- ScDefs : ScDef ';' ScDefs { $1 : $3 } ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
-- | ScDef ';' { [$1] }
-- | ScDef { [$1] }
--
-- ScDef :: { ScDef PsName }
-- ScDef : Id ParList '=' Expr { ScDef (Left $1) $2
-- ($4 & binders %~ Right) }
Type :: { Type } Type :: { Type }
: TypeApp '->' TypeApp { $1 :-> $3 } Type : Type1 { $1 }
| TypeApp { $1 }
TypeApp :: { Type }
: TypeApp Type1 { TyApp $1 $2 }
| Type1 { $1 }
-- do we want to allow symbolic names for tyvars and tycons?
Type1 :: { Type } Type1 :: { Type }
Type1 : '(' Type ')' { $2 } Type1 : '(' Type ')' { $2 }
| Type1 '->' Type { $1 :-> $3 }
-- do we want to allow symbolic names for tyvars and tycons?
| varname { TyVar $1 } | varname { TyVar $1 }
| conname { if $1 == "Type" | conname { TyCon $1 }
then TyKindType else TyCon $1 }
ParList :: { [Name] } ParList :: { [Name] }
ParList : varname ParList { $1 : $2 } ParList : Var ParList { $1 : $2 }
| {- epsilon -} { [] } | {- epsilon -} { [] }
StandaloneExpr :: { Expr Var } StandaloneExpr :: { Expr Name }
StandaloneExpr : Expr eof { $1 } StandaloneExpr : Expr eof { $1 }
Expr :: { Expr Var } Expr :: { Expr Name }
Expr : LetExpr { $1 } Expr : LetExpr { $1 }
| 'λ' Binders '->' Expr { Lam $2 $4 } | 'λ' Binders '->' Expr { Lam $2 $4 }
| Application { $1 } | Application { $1 }
| CaseExpr { $1 } | CaseExpr { $1 }
| Expr1 { $1 } | Expr1 { $1 }
LetExpr :: { Expr Var } LetExpr :: { Expr Name }
LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 } LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 } | letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
Binders :: { [Var] } Binders :: { [Name] }
Binders : Var Binders { $1 : $2 } Binders : Var Binders { $1 : $2 }
| Var { [$1] } | Var { [$1] }
Application :: { Expr Var } Application :: { Expr Name }
Application : Application AppArg { App $1 $2 } Application : Expr1 AppArgs { foldl' App $1 $2 }
| Expr1 AppArg { App $1 $2 }
AppArg :: { Expr Var } AppArgs :: { [Expr Name] }
: '@' Type1 { Type $2 } AppArgs : Expr1 AppArgs { $1 : $2 }
| Expr1 { $1 } | Expr1 { [$1] }
CaseExpr :: { Expr Var } CaseExpr :: { Expr Name }
CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 } CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 }
Alters :: { [Alter Var] } Alters :: { [Alter Name] }
Alters : Alter ';' Alters { $1 : $3 } Alters : Alter ';' Alters { $1 : $3 }
| Alter ';' { [$1] } | Alter ';' { [$1] }
| Alter { [$1] } | Alter { [$1] }
Alter :: { Alter Var } -- TODO: tags should be wrapped in <n> to allow matching against literals
Alter : alttag AltParList '->' Expr { Alter (AltTag $1) $2 $4 } Alter :: { Alter Name }
| conname AltParList '->' Expr { Alter (AltData $1) $2 $4 } Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 }
AltParList :: { [Var] } Expr1 :: { Expr Name }
: Var AltParList { $1 : $2 }
| {- epsilon -} { [] }
Expr1 :: { Expr Var }
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 }
PackCon :: { Expr Var } ExprPragma :: { Expr Name }
ExprPragma : '{-#' Words '#-}' {% exprPragma $2 }
Words :: { [String] }
Words : word Words { T.unpack $1 : $2 }
| word { [T.unpack $1] }
PackCon :: { Expr Name }
PackCon : pack '{' litint litint '}' { Con $3 $4 } PackCon : pack '{' litint litint '}' { Con $3 $4 }
Bindings :: { [Binding Var] } Bindings :: { [Binding Name] }
Bindings : Binding ';' Bindings { $1 : $3 } Bindings : Binding ';' Bindings { $1 : $3 }
| Binding ';' { [$1] } | Binding ';' { [$1] }
| Binding { [$1] } | Binding { [$1] }
Binding :: { Binding Var } Binding :: { Binding Name }
Binding : Var '=' Expr { $1 := $3 } Binding : Var '=' Expr { $1 := $3 }
Id :: { Name } Id :: { Name }
: varname { $1 } Id : Var { $1 }
| conname { $1 } | Con { $1 }
Var :: { Var } Var :: { Name }
Var : '(' varname ':' Type ')' { MkVar $2 $4 } Var : '(' varsym ')' { $2 }
| varname { $1 }
Con :: { Name }
Con : '(' consym ')' { $2 }
| conname { $1 }
{ {
parseError :: [Located CoreToken] -> P a parseError :: [Located CoreToken] -> RLPC SrcError a
parseError (Located _ t : _) = parseError (Located y x l _ : _) = addFatal err
error $ "<line>" <> ":" <> "<col>" where err = SrcError
<> ": parse error at token `" <> show t <> "'" { _errSpan = (y,x,l)
, _errSeverity = Error
, _errDiagnostic = SrcErrParse
}
exprPragma :: [String] -> RLPC (Expr Var) parseTmp :: IO (Module Name)
exprPragma ("AST" : e) = undefined parseTmp = do
exprPragma _ = undefined s <- TIO.readFile "/tmp/t.hs"
case parse s of
Left e -> error (show e)
Right (ts,_) -> pure ts
where
parse = evalRLPC def . (lexCore >=> parseCore)
astPragma :: [String] -> RLPC (Expr Var) exprPragma :: [String] -> RLPC SrcError (Expr Name)
astPragma _ = undefined exprPragma ("AST" : e) = astPragma e
exprPragma _ = addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: span
, _errSeverity = Warning
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
}
-- insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b astPragma :: [String] -> RLPC SrcError (Expr Name)
-- insTypeSig ts = programTypeSigs %~ uncurry H.insert ts astPragma = pure . read . unwords
insTypeSig :: Var -> Program Var -> Program Var insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
insTypeSig w@(MkVar _ t) = programTypeSigs %~ H.insert w t insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
-- singletonTypeSig :: (Hashable b) => (b, Type) -> Program b singletonTypeSig :: (Hashable b) => (b, Type) -> Program b
-- singletonTypeSig ts = insTypeSig ts mempty singletonTypeSig ts = insTypeSig ts mempty
insScDef :: (Hashable b) => ScDef b -> Program b -> Program b insScDef :: (Hashable b) => ScDef b -> Program b -> Program b
insScDef sc = programScDefs %~ (sc:) 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
parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var) parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr parseCoreProgR = liftRlpcErrs . parseCoreProg
parseCoreProgR :: forall m. (Monad m)
=> [Located CoreToken] -> RLPCT m (Program Var)
parseCoreProgR s = do
let p = runP (parseCoreProg s) def
case p of
(st, Just a) -> do
ddumpast a
pure a
where
ddumpast :: Show a => Program a -> RLPCT m (Program a)
ddumpast p = do
addDebugMsg "dump-parsed-core" . show $ p
pure p
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
happyBind m k = m >>= k
happyPure :: a -> RLPC a
happyPure a = pure a
doTLPragma :: Pragma -> Program Var -> P (Program Var)
-- 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
} }

159
src/Core/Parse.y.old Normal file
View File

@@ -0,0 +1,159 @@
{
module Core.Parse
( parseCore
, parseCoreExpr
, parseCoreProg
, module Core.Lex -- temp convenience
, parseTmp
, SrcError
, ParseError
, Module
)
where
import Control.Monad ((>=>))
import Data.Foldable (foldl')
import Core.Syntax
import Core.Lex
import Compiler.RLPC
import Data.Default.Class (def)
}
%name parseCore Module
%name parseCoreExpr StandaloneExpr
%name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken }
%error { parseError }
%monad { RLPC ParseError }
%token
let { Located _ _ _ TokenLet }
letrec { Located _ _ _ TokenLetrec }
module { Located _ _ _ TokenModule }
where { Located _ _ _ TokenWhere }
',' { Located _ _ _ TokenComma }
in { Located _ _ _ TokenIn }
litint { Located _ _ _ (TokenLitInt $$) }
varname { Located _ _ _ (TokenVarName $$) }
varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) }
'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow }
'=' { Located _ _ _ TokenEquals }
'(' { Located _ _ _ TokenLParen }
')' { Located _ _ _ TokenRParen }
'{' { Located _ _ _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace }
vl { Located _ _ _ TokenLBraceV }
vr { Located _ _ _ TokenRBraceV }
';' { Located _ _ _ TokenSemicolon }
eof { Located _ _ _ TokenEOF }
%%
Module :: { Module }
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
| Program Eof { Module Nothing $1 }
Eof :: { () }
Eof : eof { () }
| error { () }
StandaloneProgram :: { Program }
StandaloneProgram : Program eof { $1 }
Program :: { Program }
Program : VOpen ScDefs VClose { Program $2 }
| '{' ScDefs '}' { Program $2 }
VOpen :: { () }
VOpen : vl { () }
VClose :: { () }
VClose : vr { () }
| error { () }
ScDefs :: { [ScDef] }
ScDefs : ScDef ';' ScDefs { $1 : $3 }
| {- epsilon -} { [] }
ScDef :: { ScDef }
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
ParList :: { [Name] }
ParList : Var ParList { $1 : $2 }
| {- epsilon -} { [] }
StandaloneExpr :: { Expr }
StandaloneExpr : Expr eof { $1 }
Expr :: { Expr }
Expr : LetExpr { $1 }
| 'λ' Binders '->' Expr { Lam $2 $4 }
| Application { $1 }
| Expr1 { $1 }
LetExpr :: { Expr }
LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 }
| letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 }
| let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
Binders :: { [Name] }
Binders : Var Binders { $1 : $2 }
| Var { [$1] }
Application :: { Expr }
Application : Expr1 AppArgs { foldl' App $1 $2 }
-- TODO: Application can probably be written as a single rule, without AppArgs
AppArgs :: { [Expr] }
AppArgs : Expr1 AppArgs { $1 : $2 }
| Expr1 { [$1] }
Expr1 :: { Expr }
Expr1 : litint { IntE $1 }
| Id { Var $1 }
| '(' Expr ')' { $2 }
Bindings :: { [Binding] }
Bindings : Binding ';' Bindings { $1 : $3 }
| Binding ';' { [$1] }
| Binding { [$1] }
Binding :: { Binding }
Binding : Var '=' Expr { $1 := $3 }
Id :: { Name }
Id : Var { $1 }
| Con { $1 }
Var :: { Name }
Var : '(' varsym ')' { $2 }
| varname { $1 }
Con :: { Name }
Con : '(' consym ')' { $2 }
| conname { $1 }
{
parseError :: [Located CoreToken] -> RLPC ParseError a
parseError (Located y x l _ : _) = addFatal err
where err = SrcError
{ _errSpan = (y,x,l)
, _errSeverity = Error
, _errDiagnostic = ParErrParse
}
parseTmp :: IO Module
parseTmp = do
s <- readFile "/tmp/t.hs"
case parse s of
Left e -> error (show e)
Right (ts,_) -> pure ts
where
parse = evalRLPC def . (lexCore >=> parseCore)
}

62
src/Core/Parse/Types.hs
View File

@@ -1,62 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Core.Parse.Types
( P(..)
, psTyVars
, def
, PsName
, mkTypedScDef
)
where
--------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Default
import Data.Maybe
import Data.Tuple (swap)
import Control.Lens
import Core.Syntax
--------------------------------------------------------------------------------
newtype P a = P { runP :: PState -> (PState, Maybe a) }
deriving Functor
data PState = PState
{ _psTyVars :: [(Name, Kind)]
}
instance Applicative P where
pure a = P (, Just a)
P pf <*> P pa = P \st ->
let (st',mf) = pf st
(st'',ma) = pa st'
in (st'', mf <*> ma)
instance Monad P where
P pa >>= k = P \st ->
let (st',ma) = pa st
in case ma of
Just a -> runP (k a) st'
Nothing -> (st', Nothing)
instance MonadState PState P where
state = P . fmap ((_2 %~ Just) . review swapped)
instance Default PState where
def = undefined
makeLenses ''PState
type PsName = Either Name Var
--------------------------------------------------------------------------------
mkTypedScDef :: Name -> Type -> Name -> [Name] -> Expr Var -> ScDef Var
mkTypedScDef nt tt n as e | nt == n = ScDef n' as' e
where
n' = MkVar n tt
as' = zipWith MkVar as (tt ^.. arrowStops)

792
src/Core/Syntax.hs
View File

@@ -5,41 +5,34 @@ Description : Core ASTs and the like
{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
-- for recursion-schemes
{-# LANGUAGE DeriveTraversable, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Core.Syntax module Core.Syntax
( ( Expr(..)
-- * Core AST , Type(..)
ExprF(..), ExprF' , pattern TyInt
, ScDef(..), ScDef' , Lit(..)
, Program(..), Program' , pattern (:$)
, Type(..), Kind, pattern (:->), pattern TyInt , pattern (:@)
, AlterF(..), Alter(..), Alter', AltCon(..) , pattern (:->)
, pattern Binding, pattern Alter , Binding(..)
, Rec(..), Lit(..) , AltCon(..)
, Pragma(..) , pattern (:=)
-- ** Variables and identifiers , Rec(..)
, Name, Var(..), Tag, pattern (:^) , Alter(..)
, Binding, BindingF(..), pattern (:=), pattern (:$) , Name
, type Binding' , Tag
-- ** Working with the fixed point of ExprF , ScDef(..)
, Expr, Expr' , Module(..)
, pattern Con, pattern Var, pattern App, pattern Lam, pattern Let , Program(..)
, pattern Case, pattern Type, pattern Lit , Program'
, unliftScDef
-- * pretty-printing , programScDefs
, Out(out), WithTerseBinds(..) , programTypeSigs
, Expr'
-- * Optics , ScDef'
, HasArrowSyntax(..) , Alter'
, programScDefs, programTypeSigs, programDataTags, programTyCons , Binding'
, formalising, lambdaLifting , HasRHS(_rhs)
, HasRHS(_rhs), HasLHS(_lhs) , HasLHS(_lhs)
, _BindingF, _MkVar, _ScDef
-- ** Classy optics
, HasBinders(..), HasArrowStops(..), HasApplicants1(..), HasApplicants(..)
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -48,740 +41,145 @@ import Data.Pretty
import Data.List (intersperse) import Data.List (intersperse)
import Data.Function ((&)) import Data.Function ((&))
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.Hashable.Lifted
import Data.Foldable (traverse_)
import Data.Functor
import Data.Monoid
import Data.Functor.Classes
import Data.Text qualified as T import Data.Text qualified as T
import Data.Char import Data.Char
import Data.These
import Data.Aeson
import GHC.Generics ( Generic, Generic1
, Generically(..), Generically1(..))
import Text.Show.Deriving
import Data.Eq.Deriving
import Data.Kind qualified
import Data.Fix hiding (cata, ana)
import Data.Bifunctor (Bifunctor(..))
import Data.Bifoldable (bifoldr, Bifoldable(..))
import Data.Bifunctor.TH
import Data.Bitraversable
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
-- Lift instances for the Core quasiquoters -- Lift instances for the Core quasiquoters
import Misc import Language.Haskell.TH.Syntax (Lift)
import Misc.Lift1 import Lens.Micro.TH (makeLenses)
import Control.Lens import Lens.Micro
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data ExprF b a = VarF Name data Expr b = Var Name
| ConF Tag Int -- ^ Con Tag Arity | Con Tag Int -- ^ Con Tag Arity
| CaseF a [AlterF b a] | Case (Expr b) [Alter b]
| LamF [b] a | Lam [b] (Expr b)
| LetF Rec [BindingF b a] a | Let Rec [Binding b] (Expr b)
| AppF a a | App (Expr b) (Expr b)
| LitF Lit | Lit Lit
| TypeF Type deriving (Show, Eq, Read, Lift)
deriving (Functor, Foldable, Traversable)
type Expr b = Fix (ExprF b) -- deriving instance (Eq b) => Eq (Expr b)
instance IsString (ExprF b a) where
fromString = VarF . fromString
instance (IsString (f (Fix f))) => IsString (Fix f) where
fromString = Fix . fromString
data Type = TyFun data Type = TyFun
| TyVar Name | TyVar Name
| TyApp Type Type | TyApp Type Type
| TyCon Name | TyCon Name
| TyForall Var Type deriving (Show, Read, Lift, Eq)
| TyKindType
deriving (Show, Eq, Lift)
type Kind = Type
-- data TyCon = MkTyCon Name Kind
-- deriving (Eq, Show, Lift)
data Var = MkVar Name Type
deriving (Eq, Show, Lift, Generic)
pattern (:^) :: Name -> Type -> Var
pattern n :^ t = MkVar n t
instance Hashable Var where
hashWithSalt s (MkVar n _) = hashWithSalt s n
pattern Con :: Tag -> Int -> Expr b
pattern Con t a = Fix (ConF t a)
pattern Var :: Name -> Expr b
pattern Var b = Fix (VarF b)
pattern App :: Expr b -> Expr b -> Expr b
pattern App f x = Fix (AppF f x)
pattern Lam :: [b] -> Expr b -> Expr b
pattern Lam bs e = Fix (LamF bs e)
pattern Let :: Rec -> [Binding b] -> Expr b -> Expr b
pattern Let r bs e = Fix (LetF r bs e)
pattern Case :: Expr b -> [Alter b] -> Expr b
pattern Case e as = Fix (CaseF e as)
pattern Type :: Type -> Expr b
pattern Type t = Fix (TypeF t)
pattern Lit :: Lit -> Expr b
pattern Lit t = Fix (LitF t)
pattern TyInt :: Type pattern TyInt :: Type
pattern TyInt = TyCon "Int#" pattern TyInt = TyCon "Int#"
class HasArrowSyntax s a b | s -> a b where
_arrowSyntax :: Prism' s (a, b)
instance HasArrowSyntax Type Type Type where
_arrowSyntax = prism make unmake where
make (s,t) = TyFun `TyApp` s `TyApp` t
unmake (TyFun `TyApp` s `TyApp` t) = Right (s,t)
unmake s = Left s
infixr 1 :->
pattern (:->) :: HasArrowSyntax s a b
=> a -> b -> s
-- pattern (:->) :: Type -> Type -> Type
pattern a :-> b <- (preview _arrowSyntax -> Just (a, b))
where a :-> b = _arrowSyntax # (a, b)
data BindingF b a = BindingF b (ExprF b a)
deriving (Functor, Foldable, Traversable)
type Binding b = BindingF b (Fix (ExprF b))
type Binding' = Binding Name
-- collapse = foldFix embed
pattern Binding :: b -> Expr b -> Binding b
pattern Binding k v <- BindingF k (wrapFix -> v)
where Binding k v = BindingF k (unwrapFix v)
{-# COMPLETE (:=) #-}
{-# COMPLETE Binding #-}
infixl 1 :=
pattern (:=) :: b -> Expr b -> Binding b
pattern k := v = Binding k v
infixl 2 :$ infixl 2 :$
pattern (:$) :: Expr b -> Expr b -> Expr b pattern (:$) :: Expr b -> Expr b -> Expr b
pattern f :$ x = App f x pattern f :$ x = App f x
data AlterF b a = AlterF AltCon [b] (ExprF b a) infixl 2 :@
deriving (Functor, Foldable, Traversable) pattern (:@) :: Type -> Type -> Type
pattern f :@ x = TyApp f x
pattern Alter :: AltCon -> [b] -> Expr b -> Alter b infixr 1 :->
pattern Alter con bs e <- AlterF con bs (wrapFix -> e) pattern (:->) :: Type -> Type -> Type
where Alter con bs e = AlterF con bs (unwrapFix e) pattern a :-> b = TyApp (TyApp TyFun a) b
type Alter b = AlterF b (Fix (ExprF b)) {-# COMPLETE Binding :: Binding #-}
{-# COMPLETE (:=) :: Binding #-}
data Binding b = Binding b (Expr b)
deriving (Show, Read, Eq, Lift)
type Alter' = Alter Name infixl 1 :=
pattern (:=) :: b -> (Expr b) -> (Binding b)
pattern k := v = Binding k v
-- pattern Alter :: AltCon -> [b] -> Expr b -> Alter b data Alter b = Alter AltCon [b] (Expr b)
-- pattern Alter con bs e <- Fix (AlterF con bs (undefined -> e)) deriving (Show, Read, Eq, Lift)
-- where Alter con bs e = Fix (AlterF con bs undefined)
newtype Pragma = Pragma [T.Text]
data Rec = Rec data Rec = Rec
| NonRec | NonRec
deriving (Show, Eq, Lift) deriving (Show, Read, Eq, Lift)
data AltCon = AltData Name data AltCon = AltData Tag
| AltTag Tag
| AltLit Lit | AltLit Lit
| AltDefault | Default
deriving (Show, Eq, Lift) deriving (Show, Read, Eq, Lift)
newtype Lit = IntL Int data Lit = IntL Int
deriving (Show, Eq, Lift) deriving (Show, Read, Eq, Lift)
type Name = T.Text type Name = T.Text
type Tag = Int type Tag = Int
data ScDef b = ScDef b [b] (Expr b) data ScDef b = ScDef b [b] (Expr b)
deriving (Show, Eq, Lift)
-- unliftScDef :: ScDef b -> Expr b unliftScDef :: ScDef b -> Expr b
-- unliftScDef (ScDef _ as e) = Lam as e unliftScDef (ScDef _ as e) = Lam as e
data Module b = Module (Maybe (Name, [Name])) (Program b) data Module b = Module (Maybe (Name, [Name])) (Program b)
deriving (Show, Lift)
data Program b = Program data Program b = Program
{ _programScDefs :: [ScDef b] { _programScDefs :: [ScDef b]
, _programTypeSigs :: HashMap b Type , _programTypeSigs :: H.HashMap b Type
, _programDataTags :: HashMap Name (Tag, Int)
-- ^ map constructors to their tag and arity
, _programTyCons :: HashMap Name Kind
-- ^ map type constructors to their kind
} }
deriving (Generic) deriving (Show, Eq, Lift)
deriving (Semigroup, Monoid)
via Generically (Program b)
makeLenses ''Program makeLenses ''Program
-- makeBaseFunctor ''Expr
pure [] pure []
-- this is a weird optic, stronger than Lens and Prism, but weaker than Iso.
programTypeSigsP :: (Hashable b) => Prism' (Program b) (HashMap b Type)
programTypeSigsP = prism
(\b -> mempty & programTypeSigs .~ b)
(Right . view programTypeSigs)
type ExprF' = ExprF Name
type Program' = Program Name type Program' = Program Name
type Expr' = Expr Name type Expr' = Expr Name
type ScDef' = ScDef Name type ScDef' = ScDef Name
-- type Alter' = Alter Name type Alter' = Alter Name
-- type Binding' = Binding Name type Binding' = Binding Name
-- instance IsString (Expr b) where instance IsString (Expr b) where
-- fromString = Var . fromString fromString = Var . fromString
lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b') instance IsString Type where
lambdaLifting = iso sa bt where fromString "" = error "IsString Type string may not be empty"
sa (ScDef n as e) = (n, e') where fromString s
e' = Lam as e | isUpper c = TyCon . fromString $ s
| otherwise = TyVar . fromString $ s
where (c:_) = s
bt (n, Lam as e) = ScDef n as e instance (Hashable b) => Semigroup (Program b) where
bt (n, e) = ScDef n [] e (<>) = 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
_rhs :: Lens s t a b _rhs :: Lens s t a b
instance HasRHS (AlterF b a) (AlterF b a') (ExprF b a) (ExprF b a') where instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
_rhs = lens _rhs = lens
(\ (AlterF _ _ e) -> e) (\ (Alter _ _ e) -> e)
(\ (AlterF t as _) e' -> AlterF t as e') (\ (Alter t as _) e' -> Alter t as e')
instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where
_rhs = lens _rhs = lens
(\ (ScDef _ _ e) -> e) (\ (ScDef _ _ e) -> e)
(\ (ScDef n as _) e' -> ScDef n as e') (\ (ScDef n as _) e' -> ScDef n as e')
instance HasRHS (BindingF b a) (BindingF b' a') (ExprF b a) (ExprF b' a') instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
_rhs = lens
(\ (_ := e) -> e)
(\ (k := _) e' -> k := e')
class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
_lhs :: Lens s t a b _lhs :: Lens s t a b
instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
_lhs = lens
(\ (Alter a bs _) -> (a,bs))
(\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
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)
-- | This is not a valid isomorphism for expressions containing lambdas whose
-- bodies are themselves lambdas with multiple arguments:
--
-- >>> [coreExpr|\x -> \y z -> x|] ^. from (from formalising)
-- Lam ["x"] (Lam ["y"] (Lam ["z"] (Var "x")))
-- >>> [coreExpr|\x -> \y z -> x|]
-- Lam ["x"] (Lam ["y","z"] (Var "x"))
--
-- For this reason, it's best to consider 'formalising' as if it were two
-- unrelated unidirectional getters.
formalising :: Iso (Expr a) (Expr b) (Expr a) (Expr b)
formalising = iso sa bt where
sa :: Expr a -> Expr a
sa = ana \case
Lam [b] e -> LamF [b] e
Lam (b:bs) e -> LamF [b] (Lam bs e)
Let r (b:bs) e -> LetF r [b] (Let r bs e)
x -> project x
bt :: Expr b -> Expr b
bt = cata \case
LamF [b] (Lam bs e) -> Lam (b:bs) e
LetF r [b] (Let r' bs e) | r == r' -> Let r (b:bs) e
x -> embed x
--------------------------------------------------------------------------------
newtype WithTerseBinds a = WithTerseBinds a
class MakeTerse a where
type AsTerse a :: Data.Kind.Type
asTerse :: a -> AsTerse a
instance MakeTerse Var where
type AsTerse Var = Name
asTerse (MkVar n _) = n
instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
=> Out (WithTerseBinds (Program b)) where
out (WithTerseBinds p)
= vsep [ (datatags <> "\n")
, defs ]
where
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
defs = vlinesOf (programJoinedDefs . to prettyGroup) p
programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
programJoinedDefs = folding $ \p ->
foldMapOf programTypeSigs thisTs p
`u` foldMapOf programScDefs thatSc p
where u = H.unionWith unionThese
thisTs = ifoldMap @b @(HashMap b)
(\n t -> H.singleton n (This (n,t)))
thatSc = foldMap $ \sc ->
H.singleton (sc ^. _lhs . _1) (That sc)
prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
prettyGroup = bifoldr vs vs mempty
. bimap (uncurry prettyTySig')
(out . WithTerseBinds)
where vs a b = a <> ";" <> line <> b
cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
instance (Hashable b, Out b) => Out (Program b) where
out p = vsep [ datatags <> "\n"
, defs ]
where
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
defs = vlinesOf (programJoinedDefs . to prettyGroup) p
programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
programJoinedDefs = folding $ \p ->
foldMapOf programTypeSigs thisTs p
`u` foldMapOf programScDefs thatSc p
where u = H.unionWith unionThese
thisTs = ifoldMap @b @(HashMap b)
(\n t -> H.singleton n (This (n,t)))
thatSc = foldMap $ \sc ->
H.singleton (sc ^. _lhs . _1) (That sc)
prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
prettyGroup = bifoldr vs vs mempty
. bimap (uncurry prettyTySig) out
where vs a b = a <> ";" <> line <> b
cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
unionThese :: These a b -> These a b -> These a b
unionThese (This a) (That b) = These a b
unionThese (That b) (This a) = These a b
unionThese (These a b) _ = These a b
prettyDataTag :: (Out n, Out t, Out a)
=> n -> t -> a -> Doc ann
prettyDataTag n t a =
hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
prettyTySig :: (Out n, Out t) => n -> t -> Doc ann
prettyTySig n t = hsep [ttext n, ":", out t]
prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
-- out Type
-- TyApp | appPrec | left
-- (:->) | appPrec-1 | right
instance Out Type where
outPrec _ (TyVar n) = ttext n
outPrec _ TyFun = "(->)"
outPrec _ (TyCon n) = ttext n
outPrec p (a :-> b) = maybeParens (p>appPrec-1) $
hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
outPrec p (TyApp f x) = maybeParens (p>appPrec) $
outPrec appPrec f <+> outPrec appPrec1 x
outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
"∀" <+> (outPrec appPrec1 a <> ".") <+> out m
outPrec _ TyKindType = "Type"
instance (Out b, Out (AsTerse b), MakeTerse b)
=> Out (WithTerseBinds (ScDef b)) where
out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
where
name = ttext $ sc ^. _lhs . _1 . to asTerse
as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
e = out $ sc ^. _rhs
instance (Out b) => Out (ScDef b) where
out sc = hsep [name, as, "=", hang 1 e]
where
name = ttext $ sc ^. _lhs . _1
as = sc & hsepOf (_lhs . _2 . each . to ttext)
e = out $ sc ^. _rhs
-- out Expr
-- LamF | appPrec1 | right
-- AppF | appPrec | left
instance (Out b, Out a) => Out (ExprF b a) where
outPrec = outPrec1
instance (Out b) => Out1 (ExprF b) where
liftOutPrec pr _ (VarF n) = ttext n
liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
liftOutPrec pr p (LamF bs e) = maybeParens (p>0) $
hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", pr 0 e]
liftOutPrec pr p (LetF r bs e) = maybeParens (p>0)
$ vsep [ hsep [out r, bs']
, hsep ["in", pr 0 e] ]
where bs' = liftExplicitLayout (liftOutPrec pr 0) bs
liftOutPrec pr p (AppF f x) = maybeParens (p>appPrec) $
pr appPrec f <+> pr appPrec1 x
liftOutPrec pr p (LitF l) = outPrec p l
liftOutPrec pr p (CaseF e as) = maybeParens (p>0) $
vsep [ "case" <+> pr 0 e <+> "of"
, nest 2 as' ]
where as' = liftExplicitLayout (liftOutPrec pr 0) as
liftOutPrec pr p (TypeF t) = "@" <> outPrec appPrec1 t
instance Out Rec where
out Rec = "letrec"
out NonRec = "let"
instance (Out b, Out a) => Out (AlterF b a) where
outPrec = outPrec1
instance (Out b) => Out1 (AlterF b) where
liftOutPrec pr _ (AlterF c as e) =
hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
instance Out AltCon where
out (AltData n) = ttext n
out (AltLit l) = out l
out (AltTag t) = "<" <> ttext t <> ">"
out AltDefault = "_"
instance Out Lit where
out (IntL n) = ttext n
instance (Out b, Out a) => Out (BindingF b a) where
outPrec = outPrec1
instance Out b => Out1 (BindingF b) where
liftOutPrec pr _ (BindingF k v) = hsep [out k, "=", liftOutPrec pr 0 v]
liftExplicitLayout :: (a -> Doc ann) -> [a] -> Doc ann
liftExplicitLayout pr as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (pr <$> as)
delims = "{" : repeat ";"
explicitLayout :: (Out a) => [a] -> Doc ann
explicitLayout as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (out <$> as)
delims = "{" : repeat ";"
instance Out Var where
outPrec p (MkVar n t) = maybeParens (p>0) $
hsep [out n, ":", out t]
--------------------------------------------------------------------------------
-- instance Functor Alter where
-- fmap f (Alter con bs e) = Alter con (f <$> bs) e'
-- where
-- e' = foldFix (embed . bimap' f id) e
-- bimap' = $(makeBimap ''ExprF)
-- instance Foldable Alter where
-- instance Traversable Alter where
-- instance Functor Binding where
-- instance Foldable Binding where
-- instance Traversable Binding where
liftShowsPrecExpr :: (Show b)
=> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int -> ExprF b a -> ShowS
liftShowsPrecExpr = $(makeLiftShowsPrec ''ExprF)
showsPrec1Expr :: (Show b, Show a)
=> Int -> ExprF b a -> ShowS
showsPrec1Expr = $(makeShowsPrec1 ''ExprF)
instance (Show b) => Show1 (AlterF b) where
liftShowsPrec sp spl d (AlterF con bs e) =
showsTernaryWith showsPrec showsPrec (liftShowsPrecExpr sp spl)
"AlterF" d con bs e
instance (Show b) => Show1 (BindingF b) where
liftShowsPrec sp spl d (BindingF k v) =
showsBinaryWith showsPrec (liftShowsPrecExpr sp spl)
"BindingF" d k v
instance (Show b, Show a) => Show (BindingF b a) where
showsPrec d (BindingF k v)
= showParen (d > 10)
$ showString "BindingF" . showChar ' '
. showsPrec 11 k . showChar ' '
. showsPrec1Expr 11 v
instance (Show b, Show a) => Show (AlterF b a) where
showsPrec d (AlterF con bs e)
= showParen (d > 10)
$ showString "AlterF" . showChar ' '
. showsPrec 11 con . showChar ' '
. showsPrec 11 bs . showChar ' '
. showsPrec1Expr 11 e
deriveShow1 ''ExprF
deriving instance (Show b, Show a) => Show (ExprF b a)
-- deriving instance (Show b, Show a) => Show (BindingF b a)
-- deriving instance (Show b, Show a) => Show (AlterF b a)
deriving instance Show b => Show (ScDef b)
deriving instance Show b => Show (Program b)
bimapExpr :: (b -> b') -> (a -> a')
-> ExprF b a -> ExprF b' a'
bimapExpr = $(makeBimap ''ExprF)
bifoldrExpr :: (b -> c -> c)
-> (a -> c -> c)
-> c -> ExprF b a -> c
bifoldrExpr = $(makeBifoldr ''ExprF)
bitraverseExpr :: Applicative f
=> (b -> f b')
-> (a -> f a')
-> ExprF b a -> f (ExprF b' a')
bitraverseExpr = $(makeBitraverse ''ExprF)
instance Bifunctor AlterF where
bimap f g (AlterF con bs e) = AlterF con (f <$> bs) (bimapExpr f g e)
instance Bifunctor BindingF where
bimap f g (BindingF k v) = BindingF (f k) (bimapExpr f g v)
instance Bifoldable AlterF where
bifoldr f g z (AlterF con bs e) = bifoldrExpr f g z' e where
z' = foldr f z bs
instance Bitraversable AlterF where
bitraverse f g (AlterF con bs e) =
AlterF con <$> traverse f bs <*> bitraverseExpr f g e
instance Bifoldable BindingF where
bifoldr f g z (BindingF k v) = bifoldrExpr f g (f k z) v
instance Bitraversable BindingF where
bitraverse f g (BindingF k v) =
BindingF <$> f k <*> bitraverseExpr f g v
deriveBifunctor ''ExprF
deriveBifoldable ''ExprF
deriveBitraversable ''ExprF
instance Lift b => Lift1 (BindingF b) where
liftLift lf (BindingF k v) = liftCon2 'BindingF (lift k) (liftLift lf v)
instance Lift b => Lift1 (AlterF b) where
liftLift lf (AlterF con bs e) =
liftCon3 'AlterF (lift con) (lift1 bs) (liftLift lf e)
instance Lift b => Lift1 (ExprF b) where
liftLift lf (VarF k) = liftCon 'VarF (lift k)
liftLift lf (AppF f x) = liftCon2 'AppF (lf f) (lf x)
liftLift lf (LamF b e) = liftCon2 'LamF (lift b) (lf e)
liftLift lf (LetF r bs e) = liftCon3 'LetF (lift r) bs' (lf e)
where bs' = liftLift (liftLift lf) bs
liftLift lf (CaseF e as) = liftCon2 'CaseF (lf e) as'
where as' = liftLift (liftLift lf) as
liftLift lf (TypeF t) = liftCon 'TypeF (lift t)
liftLift lf (LitF l) = liftCon 'LitF (lift l)
liftLift lf (ConF t a) = liftCon2 'ConF (lift t) (lift a)
deriving instance (Lift b, Lift a) => Lift (ExprF b a)
deriving instance (Lift b, Lift a) => Lift (BindingF b a)
deriving instance (Lift b, Lift a) => Lift (AlterF b a)
deriving instance Lift b => Lift (ScDef b)
deriving instance Lift b => Lift (Program b)
--------------------------------------------------------------------------------
class HasApplicants1 s t a b | s -> a, t -> b, s b -> t, t a -> s where
applicants1 :: Traversal s t a b
class HasApplicants s t a b | s -> a, t -> b, s b -> t, t a -> s where
applicants :: Traversal s t a b
instance HasApplicants1 Type Type Type Type where
applicants1 k (TyApp f x) = TyApp <$> applicants1 k f <*> k x
applicants1 k x = k x
instance HasApplicants Type Type Type Type where
applicants k (TyApp f x) = TyApp <$> applicants k f <*> k x
applicants k x = pure x
-- instance HasArguments (ExprF b (Fix (ExprF b))) (ExprF b (Fix (ExprF b)))
-- (Fix (ExprF b)) (Fix (ExprF b)) where
-- arguments k (AppF f x) = AppF <$> arguments k f <*> k x
-- arguments k x = unwrapFix <$> k (wrapFix x)
-- instance HasArguments (f (Fix f)) (f (Fix f)) (Fix f) (Fix f)
-- => HasArguments (Fix f) (Fix f) (Fix f) (Fix f) where
-- arguments :: forall g. Applicative g
-- => LensLike' g (Fix f) (Fix f)
-- arguments k (Fix f) = Fix <$> arguments k f
-- arguments :: Traversal' (Expr b) (Expr b)
-- arguments k (App f x) = App <$> arguments k f <*> k x
-- arguments k x = k x
class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
binders :: Traversal s t a b
instance HasBinders (ScDef b) (ScDef b') b b' where
binders k (ScDef b as e) = ScDef <$> k b <*> traverse k as <*> binders k e
instance (Hashable b, Hashable b')
=> HasBinders (Program b) (Program b') b b' where
binders :: forall f. (Applicative f)
=> LensLike f (Program b) (Program b') b b'
binders k p
= Program
<$> traverse (binders k) (_programScDefs p)
<*> (getAp . ifoldMap toSingleton $ _programTypeSigs p)
<*> pure (_programDataTags p)
<*> pure (_programTyCons p)
where
toSingleton :: b -> Type -> Ap f (HashMap b' Type)
toSingleton b t = Ap $ (`H.singleton` t) <$> k b
instance HasBinders a a' b b'
=> HasBinders (ExprF b a) (ExprF b' a') b b' where
binders :: forall f. (Applicative f)
=> LensLike f (ExprF b a) (ExprF b' a') b b'
binders k = go where
go :: ExprF b a -> f (ExprF b' a')
go (LamF bs e) = LamF <$> traverse k bs <*> binders k e
go (CaseF e as) = CaseF <$> binders k e <*> eachbind as
go (LetF r bs e) = LetF r <$> eachbind bs <*> binders k e
go f = bitraverse k (binders k) f
eachbind :: forall p. Bitraversable p => [p b a] -> f [p b' a']
eachbind bs = bitraverse k (binders k) `traverse` bs
instance HasBinders a a b b'
=> HasBinders (AlterF b a) (AlterF b' a) b b' where
binders k (AlterF con bs e) =
AlterF con <$> traverse k bs <*> traverseOf binders k e
instance HasBinders a a b b'
=> HasBinders (BindingF b a) (BindingF b' a) b b' where
binders k (BindingF b v) = BindingF <$> k b <*> binders k v
instance (HasBinders (f b (Fix (f b))) (f b' (Fix (f b'))) b b')
=> HasBinders (Fix (f b)) (Fix (f b')) b b' where
binders k (Fix f) = Fix <$> binders k f
class HasArrowStops s t a b | s -> a, t -> b, s b -> t, t a -> s where
arrowStops :: Traversal s t a b
instance HasArrowStops Type Type Type Type where
arrowStops k (s :-> t) = (:->) <$> k s <*> arrowStops k t
arrowStops k t = k t
--------------------------------------------------------------------------------
liftEqExpr :: (Eq b)
=> (a -> a' -> Bool)
-> ExprF b a -> ExprF b a' -> Bool
liftEqExpr = $(makeLiftEq ''ExprF)
instance (Eq b, Eq a) => Eq (BindingF b a) where
BindingF ka va == BindingF kb vb =
ka == kb && va `eq` vb
where eq = liftEqExpr (==)
instance (Eq b, Eq a) => Eq (AlterF b a) where
AlterF cona bsa ea == AlterF conb bsb eb =
cona == conb && bsa == bsb && ea `eq` eb
where eq = liftEqExpr (==)
instance (Eq b) => Eq1 (AlterF b) where
liftEq f (AlterF cona bsa ea) (AlterF conb bsb eb) =
cona == conb && bsa == bsb && ea `eq` eb
where eq = liftEqExpr f
instance (Eq b) => Eq1 (BindingF b) where
liftEq f (BindingF ka va) (BindingF kb vb) =
ka == kb && va `eq` vb
where eq = liftEqExpr f
deriveEq1 ''ExprF
deriving instance (Eq b, Eq a) => Eq (ExprF b a)
makePrisms ''BindingF
makePrisms ''Var
makePrisms ''ScDef
deriving instance Generic (ExprF b a)
deriving instance Generic1 (ExprF b)
deriving instance Generic1 (AlterF b)
deriving instance Generic1 (BindingF b)
deriving instance Generic (AlterF b a)
deriving instance Generic (BindingF b a)
deriving instance Generic AltCon
deriving instance Generic Lit
deriving instance Generic Rec
deriving instance Generic Type
instance Hashable Lit
instance Hashable AltCon
instance Hashable Rec
instance Hashable Type
instance (Hashable b, Hashable a) => Hashable (BindingF b a)
instance (Hashable b, Hashable a) => Hashable (AlterF b a)
instance (Hashable b, Hashable a) => Hashable (ExprF b a)
instance Hashable b => Hashable1 (AlterF b)
instance Hashable b => Hashable1 (BindingF b)
instance Hashable b => Hashable1 (ExprF b)
deriving via (Generically Rec)
instance ToJSON Rec
deriving via (Generically Lit)
instance ToJSON Lit
deriving via (Generically AltCon)
instance ToJSON AltCon
deriving via (Generically Type)
instance ToJSON Type
deriving via (Generically Var)
instance ToJSON Var
deriving via (Generically1 (BindingF b))
instance ToJSON b => ToJSON1 (BindingF b)
deriving via (Generically1 (AlterF b))
instance ToJSON b => ToJSON1 (AlterF b)
deriving via (Generically1 (ExprF b))
instance ToJSON b => ToJSON1 (ExprF b)

269
src/Core/SystemF.hs
View File

@@ -1,269 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedLists #-}
module Core.SystemF
( lintCoreProgR
, kindOf
)
where
--------------------------------------------------------------------------------
import GHC.Generics (Generic, Generically(..))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Data.Function (on)
import Data.Traversable
import Data.Foldable
import Data.List.Extra
import Control.Monad.Utils
import Control.Monad
import Data.Text qualified as T
import Data.Pretty
import Text.Printf
import Control.Comonad
import Control.Comonad.Cofree
import Data.Fix
import Data.Functor hiding (unzip)
import Control.Lens hiding ((:<))
import Control.Lens.Unsound
import Compiler.RLPC
import Compiler.RlpcError
import Core
--------------------------------------------------------------------------------
data Gamma = Gamma
{ _gammaVars :: HashMap Name Type
, _gammaTyVars :: HashMap Name Kind
, _gammaTyCons :: HashMap Name Kind
}
deriving (Generic)
deriving (Semigroup, Monoid)
via (Generically Gamma)
makeLenses ''Gamma
lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
lintCoreProgR = liftEither . (_Left %~ pure) . lint
lintDontCheck :: Program Var -> Program Name
lintDontCheck = binders %~ view (_MkVar . _1)
lint :: Program Var -> SysF (Program Name)
lint p = do
scs <- traverse (lintScDef g0) $ p ^. programScDefs
pure $ lintDontCheck p & programScDefs .~ scs
where
g0 = mempty & gammaVars .~ typeSigs
& gammaTyCons .~ p ^. programTyCons
-- 'p' stores the type signatures as 'HashMap Var Type',
-- while our typechecking context demands a 'HashMap Name Type'.
-- This conversion is perfectly safe, as the 'Hashable' instance for
-- 'Var' hashes exactly the internal 'Name'. i.e.
-- `hash (MkVar n t) = hash n`.
typeSigs = p ^. programTypeSigs
& H.mapKeys (view $ _MkVar . _1)
lintScDef :: Gamma -> ScDef Var -> SysF (ScDef Name)
lintScDef g = traverseOf lambdaLifting $ \ (MkVar n t, e) -> do
e'@(t' :< _) <- lintE g e
assertUnify t t'
let e'' = stripVars . stripTypes $ e'
pure (n, e'')
stripTypes :: ET -> Expr Var
stripTypes (_ :< as) = Fix (stripTypes <$> as)
stripVars :: Expr Var -> Expr Name
stripVars = binders %~ view (_MkVar . _1)
type ET = Cofree (ExprF Var) Type
type SysF = Either SystemFError
data SystemFError = SystemFErrorUndefinedVariable Name
| SystemFErrorKindMismatch Kind Kind
| SystemFErrorCouldNotMatch Type Type
deriving Show
instance IsRlpcError SystemFError where
liftRlpcError = \case
SystemFErrorUndefinedVariable n ->
undefinedVariableErr n
SystemFErrorKindMismatch k k' ->
Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
(out k) (out k')
]
SystemFErrorCouldNotMatch t t' ->
Text [ T.pack $ printf "Could not match type `%s' with `%s'"
(out t) (out t')
]
justLintCoreExpr = fmap (fmap (outPrec appPrec1)) . lintE demoContext
lintE :: Gamma -> Expr Var -> SysF ET
lintE g = \case
Var n -> lookupVar g n <&> (:< VarF n)
Lit (IntL n) -> pure $ TyInt :< LitF (IntL n)
Type t -> kindOf g t <&> (:< TypeF t)
App f x
-- type application
| Right (TyForall (a :^ k) m :< f') <- lintE g f
, Right (k' :< TypeF t) <- lintE g x
, k == k'
-> pure $ subst a t m :< f'
-- value application
| Right fw@((s :-> t) :< _) <- lintE g f
, Right xw@(s' :< _) <- lintE g x
, s == s'
-> pure $ t :< AppF fw xw
Lam bs e -> do
e'@(t :< _) <- lintE g' e
pure $ foldr arrowify t bs :< LamF bs e'
where
g' = foldMap suppl bs <> g
suppl (MkVar n t)
| isKind t = mempty & gammaTyVars %~ H.insert n t
| otherwise = mempty & gammaVars %~ H.insert n t
arrowify (MkVar n s) s'
| isKind s = TyForall (n :^ s) s'
| otherwise = s :-> s'
Let Rec bs e -> do
e'@(t :< _) <- lintE g' e
bs' <- (uncurry checkBind . (_2 %~ wrapFix)) `traverse` binds
pure $ t :< LetF Rec bs' e'
where
binds = bs ^.. each . _BindingF
vs = binds ^.. each . _1 . _MkVar
g' = supplementVars vs g
checkBind v@(MkVar n t) e = case lintE g' e of
Right (t' :< e') | t == t' -> Right (BindingF v e')
| otherwise -> Left (SystemFErrorCouldNotMatch t t')
Left e -> Left e
Let NonRec bs e -> do
(g',bs') <- mapAccumLM checkBind g bs
e'@(t :< _) <- lintE g' e
pure $ t :< LetF NonRec bs' e'
where
checkBind :: Gamma -> BindingF Var (Expr Var)
-> SysF (Gamma, BindingF Var ET)
checkBind g (BindingF v@(n :^ t) e) = case lintE g (wrapFix e) of
Right (t' :< e')
| t == t' -> Right (supplementVar n t g, BindingF v e')
| otherwise -> Left (SystemFErrorCouldNotMatch t t')
Left e -> Left e
Case e as -> do
e'@(et :< _) <- lintE g e
(ts,as') <- unzip <$> checkAlt et `traverse` as
case allUnify ts of
Just err -> Left err
Nothing -> pure $ head ts :< CaseF e' as'
where
checkAlt :: Type -> Alter Var -> SysF (Type, AlterF Var ET)
checkAlt scrutineeType (AlterF (AltData con) bs e) = do
ct <- lookupVar g con
ct' <- foldrMOf applicants (elimForall g) ct scrutineeType
zipWithM_ fzip bs (ct' ^.. arrowStops)
(t :< e') <- lintE (supplementVars (varsToPairs bs) g) (wrapFix e)
pure (t, AlterF (AltData con) bs e')
where
fzip (MkVar _ t) t'
| t == t' = Right ()
| otherwise = Left (SystemFErrorCouldNotMatch t t')
assertUnify :: Type -> Type -> SysF ()
assertUnify t t'
| t == t' = pure ()
| otherwise = Left (SystemFErrorCouldNotMatch t t')
allUnify :: [Type] -> Maybe SystemFError
allUnify [] = Nothing
allUnify [t] = Nothing
allUnify (t:t':ts)
| t == t' = allUnify ts
| otherwise = Just (SystemFErrorCouldNotMatch t t')
elimForall :: Gamma -> Type -> Type -> SysF Type
elimForall g t (TyForall (n :^ k) m) = do
k' <- kindOf g t
case k == k' of
True -> pure $ subst n t m
False -> Left $ SystemFErrorKindMismatch k k'
elimForall _ m _ = pure m
varsToPairs :: [Var] -> [(Name, Type)]
varsToPairs = toListOf (each . _MkVar)
checkAgainst :: Gamma -> Var -> Expr Var -> SysF ET
checkAgainst g v@(MkVar n t) e = case lintE g e of
Right e'@(t' :< _) | t == t' -> Right e'
| otherwise -> Left (SystemFErrorCouldNotMatch t t')
Left a -> Left a
supplementVars :: [(Name, Type)] -> Gamma -> Gamma
supplementVars vs = gammaVars <>~ H.fromList vs
supplementVar :: Name -> Type -> Gamma -> Gamma
supplementVar n t = gammaVars %~ H.insert n t
supplementTyVar :: Name -> Kind -> Gamma -> Gamma
supplementTyVar n t = gammaTyVars %~ H.insert n t
subst :: Name -> Type -> Type -> Type
subst k v (TyVar n) | k == n = v
subst k v (TyForall (MkVar n k') t)
| k /= n = TyForall (MkVar n k') (subst k v t)
| otherwise = TyForall (MkVar n k') t
subst k v (TyApp f x) = (TyApp `on` subst k v) f x
subst _ _ x = x
isKind :: Type -> Bool
isKind (s :-> t) = isKind s && isKind t
isKind TyKindType = True
isKind _ = False
kindOf :: Gamma -> Type -> SysF Kind
kindOf g (TyVar n) = lookupTyVar g n
kindOf _ TyKindType = pure TyKindType
kindOf g (TyCon n) = lookupCon g n
kindOf _ e = error (show e)
lookupCon :: Gamma -> Name -> SysF Kind
lookupCon g n = case g ^. gammaTyCons . at n of
Just k -> Right k
Nothing -> Left (SystemFErrorUndefinedVariable n)
lookupVar :: Gamma -> Name -> SysF Type
lookupVar g n = case g ^. gammaVars . at n of
Just t -> Right t
Nothing -> Left (SystemFErrorUndefinedVariable n)
lookupTyVar :: Gamma -> Name -> SysF Kind
lookupTyVar g n = case g ^. gammaTyVars . at n of
Just k -> Right k
Nothing -> Left (SystemFErrorUndefinedVariable n)
demoContext :: Gamma
demoContext = Gamma
{ _gammaVars =
[ ("id", TyForall ("a" :^ TyKindType) $ TyVar "a" :-> TyVar "a")
, ("Just", TyForall ("a" :^ TyKindType) $
TyVar "a" :-> (TyCon "Maybe" `TyApp` TyVar "a"))
, ("Nothing", TyForall ("a" :^ TyKindType) $
TyCon "Maybe" `TyApp` TyVar "a")
]
, _gammaTyVars = []
, _gammaTyCons =
[ ("Int#", TyKindType)
, ("Maybe", TyKindType :-> TyKindType)
]
}

90
src/Core/TH.hs
View File

@@ -5,8 +5,8 @@ Description : Core quasiquoters
module Core.TH module Core.TH
( coreExpr ( coreExpr
, coreProg , coreProg
-- , coreExprT , coreProgT
-- , coreProgT , core
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -14,46 +14,74 @@ import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (Module) import Language.Haskell.TH.Syntax hiding (Module)
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import Control.Monad.IO.Class
import Control.Arrow ((>>>))
import Compiler.RLPC import Compiler.RLPC
import Data.Default.Class (def) import Data.Default.Class (def)
import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import Core.Parse import Core.Parse
import Core.Lex import Core.Lex
import Core.Syntax import Core.HindleyMilner (checkCoreProgR)
import Core.HindleyMilner (checkCoreProgR, checkCoreExprR)
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
coreProg :: QuasiQuoter -- TODO: write in terms of a String -> QuasiQuoter
coreProg = mkqq $ lexCoreR >=> parseCoreProgR
coreExpr :: QuasiQuoter core :: QuasiQuoter
coreExpr = mkqq $ lexCoreR >=> parseCoreExprR core = QuasiQuoter
{ quoteExp = qCore
-- | Type-checked @coreProg@
-- coreProgT :: QuasiQuoter
-- coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
-- coreExprT :: QuasiQuoter
-- coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
-- where
-- g = [ ("+#", TyInt :-> TyInt :-> TyInt)
-- , ("id", TyForall (MkVar "a" TyKindType) $
-- TyVar "a" :-> TyVar "a")
-- , ("fix", TyForall (MkVar "a" TyKindType) $
-- (TyVar "a" :-> TyVar "a") :-> TyVar "a")
-- ]
mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
mkqq p = QuasiQuoter
{ quoteExp = mkq p
, quotePat = error "core quasiquotes may only be used in expressions" , quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions" , quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions" , quoteDec = error "core quasiquotes may only be used in expressions"
} }
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp coreProg :: QuasiQuoter
mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift coreProg = QuasiQuoter
{ quoteExp = qCoreProg
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
coreExpr :: QuasiQuoter
coreExpr = QuasiQuoter
{ quoteExp = qCoreExpr
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
-- | Type-checked @coreProg@
coreProgT :: QuasiQuoter
coreProgT = QuasiQuoter
{ quoteExp = qCoreProgT
, quotePat = error "core quasiquotes may only be used in expressions"
, quoteType = error "core quasiquotes may only be used in expressions"
, quoteDec = error "core quasiquotes may only be used in expressions"
}
qCore :: String -> Q Exp
qCore s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parse = evalRLPC def . (lexCore >=> parseCore)
qCoreExpr :: String -> Q Exp
qCoreExpr s = case parseExpr (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
qCoreProg :: String -> Q Exp
qCoreProg s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
qCoreProgT :: String -> Q Exp
qCoreProgT s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,_) -> lift m
where
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)

77
src/Core/Utils.hs
View File

@@ -1,8 +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
, extractProgram
, freeVariables , freeVariables
, ExprF(..)
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -11,15 +19,17 @@ import Data.Functor.Foldable
import Data.Set (Set) import Data.Set (Set)
import Data.Set qualified as S import Data.Set qualified as S
import Core.Syntax import Core.Syntax
import Control.Lens 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
@@ -28,29 +38,36 @@ isAtomic _ = False
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
freeVariables :: Expr b -> Set b -- TODO: export list awareness
freeVariables = undefined -- insertModule :: Module b -> Program b -> Program b
-- insertModule (Module _ p) = programScDefs %~ (<>m)
-- freeVariables :: Expr' -> Set Name extractProgram :: Module b -> Program b
-- freeVariables = cata go extractProgram (Module _ p) = p
-- where
-- go :: ExprF Name (Set Name) -> Set Name
-- go (VarF k) = S.singleton k
-- -- TODO: collect free vars in rhss of bs
-- go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns
-- where
-- es = bs ^.. each . _rhs :: [Expr']
-- ns = S.fromList $ bs ^.. each . _lhs
-- -- TODO: this feels a little wrong. maybe a different scheme is
-- -- appropriate
-- esFree = foldMap id $ freeVariables <$> es
-- go (CaseF e as) = e `S.union` asFree ----------------------------------------------------------------------------------
-- where
-- -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as) makeBaseFunctor ''Expr
-- asFree = foldMap (freeVariables . altToLam) as
-- -- we map alts to lambdas to avoid writing a 'freeVariablesAlt' freeVariables :: Expr' -> Set Name
-- altToLam (Alter _ ns e) = Lam ns e freeVariables = cata go
-- go (LamF bs e) = e `S.difference` (S.fromList bs) where
-- go e = foldMap id e go :: ExprF Name (Set Name) -> Set Name
go (VarF k) = S.singleton k
-- TODO: collect free vars in rhss of bs
go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns
where
es = rhssOf bs :: [Expr']
ns = bindersOf bs
-- TODO: this feels a little wrong. maybe a different scheme is
-- appropriate
esFree = foldMap id $ freeVariables <$> es
go (CaseF e as) = e `S.union` asFree
where
asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
-- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
altToLam (Alter _ ns e) = Lam ns e
go (LamF bs e) = e `S.difference` (S.fromList bs)
go e = foldMap id e

75
src/Core2Core.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-}
module Core2Core module Core2Core
( core2core ( core2core
, gmPrep , gmPrep
@@ -14,77 +14,36 @@ import Data.Maybe (fromJust)
import Data.Set (Set) import Data.Set (Set)
import Data.Set qualified as S import Data.Set qualified as S
import Data.List import Data.List
import Data.Foldable
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
import Data.Pretty
import Compiler.RLPC
import Control.Lens
import Core.Syntax import Core.Syntax
import Core.Utils import Core.Utils
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
-- | General optimisations
core2core :: Program' -> Program' core2core :: Program' -> Program'
core2core p = undefined core2core p = undefined
gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
gmPrepR p = do
let p' = gmPrep p
addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
pure p'
-- | G-machine-specific preprocessing.
gmPrep :: Program' -> Program' gmPrep :: Program' -> Program'
gmPrep p = p & appFloater (floatNonStrictCases globals) gmPrep p = p' & programScDefs %~ (<>caseScs)
& tagData
& defineData
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
-- | Define concrete supercombinators for all datatags defined via pragmas (or -- i kinda don't like that we're calling floatNonStrictCases twice tbh
-- desugaring) p' = p & rhss %~ fst . runFloater . floatNonStrictCases globals
caseScs = (p ^.. rhss)
defineData :: Program' -> Program' <&> snd . runFloater . floatNonStrictCases globals
defineData p = p & programScDefs <>~ defs & mconcat
where
defs = p ^. programDataTags
. to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)]))
-- | Substitute all pattern matches on named constructors for matches on tags
tagData :: Program' -> Program'
tagData p = let ?dt = p ^. programDataTags
in p & programRhss %~ cata go where
go :: (?dt :: HashMap Name (Tag, Int)) => ExprF' Expr' -> Expr'
go (CaseF e as) = Case e (tagAlts <$> as)
go x = embed x
tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
where tag = case ?dt ^. at c of
Just (t,_) -> t
-- TODO: errorful
Nothing -> error $ "unknown constructor " <> show c
tagAlts x = x
-- | Auxilary type used in @floatNonSrictCases@ -- | 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)
-- TODO: move NameSupply from Rlp2Core into a common module to share here
runFloater :: Floater a -> (a, [ScDef']) runFloater :: Floater a -> (a, [ScDef'])
runFloater = flip evalStateT ns >>> runWriter runFloater = flip evalStateT ns >>> runWriter
where where
@@ -114,23 +73,23 @@ floatNonStrictCases g = goE
altBodies = (\(Alter _ _ b) -> b) <$> as altBodies = (\(Alter _ _ b) -> b) <$> as
tell [sc] tell [sc]
goE e goE e
traverse_ goE altBodies traverse goE altBodies
pure e' pure e'
goC (App f x) = App <$> goC f <*> goC x goC (f :$ x) = (:$) <$> goC f <*> goC x
goC (Let r bs e) = Let r <$> bs' <*> goE e goC (Let r bs e) = Let r <$> bs' <*> goE e
where bs' = travBs goC bs where bs' = travBs goC bs
goC (Lit l) = pure (Lit l) goC (Lit l) = pure (Lit l)
goC (Var k) = pure (Var k) goC (Var k) = pure (Var k)
goC (Con t as) = pure (Con t as) goC (Con t as) = pure (Con t as)
name = state (fromJust . Data.List.uncons) name = state (fromJust . uncons)
-- extract the right-hand sides of a list of bindings, traverse each -- extract the right-hand sides of a list of bindings, traverse each
-- one, and return the original list of bindings -- one, and return the original list of bindings
travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding'] travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding']
travBs c bs = undefined travBs c bs = bs ^.. each . _rhs
-- ^ ??? what the fuck? & traverse goC
-- ^ 24/02/22: what is this shit lol? & const (pure bs)
-- when provided with a case expr, floatCase will float the case into a -- when provided with a case expr, floatCase will float the case into a
-- supercombinator of its free variables. the sc is returned along with an -- supercombinator of its free variables. the sc is returned along with an

18
src/Data/Heap.hs
View File

@@ -27,7 +27,6 @@ import Debug.Trace
import Data.Map.Strict qualified as M import Data.Map.Strict qualified as M
import Data.List (intersect) import Data.List (intersect)
import GHC.Stack (HasCallStack) import GHC.Stack (HasCallStack)
import Control.Lens
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data Heap a = Heap [Addr] (Map Addr a) data Heap a = Heap [Addr] (Map Addr a)
@@ -35,21 +34,6 @@ data Heap a = Heap [Addr] (Map Addr a)
type Addr = Int type Addr = Int
type instance Index (Heap a) = Addr
type instance IxValue (Heap a) = a
instance Ixed (Heap a) where
ix a k (Heap as m) = Heap as <$> M.alterF k' a m where
k' (Just v) = Just <$> k v
k' Nothing = pure Nothing
instance At (Heap a) where
at ma k (Heap as m) = Heap as <$> M.alterF k ma m
instance FoldableWithIndex Addr Heap where
ifoldr fi z (Heap _ m) = ifoldr fi z m
ifoldMap iam (Heap _ m) = ifoldMap iam m
instance Semigroup (Heap a) where instance Semigroup (Heap a) where
Heap ua ma <> Heap ub mb = Heap u m Heap ua ma <> Heap ub mb = Heap u m
where where
@@ -70,7 +54,7 @@ instance Foldable Heap where
length (Heap _ m) = M.size m length (Heap _ m) = M.size m
instance Traversable Heap where instance Traversable Heap where
traverse t (Heap u m) = Heap u <$> traverse t m traverse t (Heap u m) = Heap u <$> (traverse t m)
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------

146
src/Data/Pretty.hs
View File

@@ -1,110 +1,80 @@
{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
module Data.Pretty module Data.Pretty
( Out(..), Out1(..) ( Pretty(..)
, outPrec1 , ISeq(..)
, rout , precPretty
, ttext , prettyPrint
, Showing(..) , prettyShow
-- * Out-printing lens combinators , iShow
, hsepOf, vsepOf, vcatOf, vlinesOf , iBracket
, module Prettyprinter , withPrec
, maybeParens , bracketPrec
, appPrec
, appPrec1
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Prettyprinter import Data.String (IsString(..))
import Text.Printf
import Data.String (IsString(..))
import Data.Text.Lens hiding ((:<))
import Data.Monoid hiding (Sum)
import Data.Bool
import Control.Lens
-- instances
import Control.Comonad.Cofree
import Data.Text qualified as T
import Data.Functor.Sum
import Data.Fix (Fix(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
class Out a where class Pretty a where
out :: a -> Doc ann pretty :: a -> ISeq
outPrec :: Int -> a -> Doc ann prettyPrec :: a -> Int -> ISeq
{-# MINIMAL out | outPrec #-} {-# MINIMAL pretty | prettyPrec #-}
out = outPrec 0 pretty a = prettyPrec a 0
outPrec = const out prettyPrec a _ = iBracket (pretty a)
rout :: (IsString s, Out a) => a -> s precPretty :: (Pretty a) => Int -> a -> ISeq
rout = fromString . show . out precPretty = flip prettyPrec
-- instance Out (Doc ann) where prettyPrint :: (Pretty a) => a -> IO ()
-- out = id prettyPrint = putStr . squash . pretty
instance Out String where prettyShow :: (Pretty a) => a -> String
out = pretty prettyShow = squash . pretty
instance Out T.Text where data ISeq where
out = pretty INil :: ISeq
IStr :: String -> ISeq
IAppend :: ISeq -> ISeq -> ISeq
IIndent :: ISeq -> ISeq
IBreak :: ISeq
newtype Showing a = Showing a instance IsString ISeq where
fromString = IStr
instance (Show a) => Out (Showing a) where instance Semigroup ISeq where
outPrec p (Showing a) = fromString $ showsPrec p a "" (<>) = IAppend
deriving via Showing Int instance Out Int instance Monoid ISeq where
mempty = INil
class (forall a. Out a => Out (f a)) => Out1 f where squash :: ISeq -> String
liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann squash a = flatten 0 [(a,0)]
outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann flatten :: Int -> [(ISeq, Int)] -> String
outPrec1 = liftOutPrec outPrec flatten _ [] = ""
flatten c ((INil, i) : ss) = flatten c ss
flatten c ((IStr s, i) : ss) = s ++ flatten (c + length s) ss
flatten c ((IAppend r s, i) : ss) = flatten c ((r,i) : (s,i) : ss)
flatten _ ((IBreak, i) : ss) = '\n' : replicate i ' ' ++ flatten i ss
flatten c ((IIndent s, i) : ss) = flatten c ((s,c) : ss)
instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where iBracket :: ISeq -> ISeq
outPrec p (InL fa) = outPrec1 p fa iBracket s = IStr "(" <> s <> IStr ")"
outPrec p (InR ga) = outPrec1 p ga
instance (Out1 f, Out1 g) => Out1 (Sum f g) where withPrec :: Int -> ISeq -> Int -> ISeq
liftOutPrec pr p (InL fa) = liftOutPrec pr p fa withPrec n s p
liftOutPrec pr p (InR ga) = liftOutPrec pr p ga | p > n = iBracket s
| otherwise = s
instance (Out (f (Fix f))) => Out (Fix f) where bracketPrec :: Int -> Int -> ISeq -> ISeq
outPrec d (Fix f) = outPrec d f bracketPrec n p s = withPrec n s p
-------------------------------------------------------------------------------- iShow :: (Show a) => a -> ISeq
iShow = IStr . show
ttext :: Out t => t -> Doc ann ----------------------------------------------------------------------------------
ttext = out
hsepOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
hsepOf l = foldrOf l (<+>) mempty
vsepOf :: _ -> s -> Doc ann
vsepOf l = vsep . toListOf l
vcatOf :: _ -> s -> Doc ann
vcatOf l = vcat . toListOf l
vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
-- hack(?) to separate chunks with a blankline
--------------------------------------------------------------------------------
maybeParens :: Bool -> Doc ann -> Doc ann
maybeParens = bool id parens
appPrec, appPrec1 :: Int
appPrec = 10
appPrec1 = 11
instance PrintfArg (Doc ann) where
formatArg d fmt
| fmtChar (vFmt 'D' fmt) == 'D' = formatString (show d) fmt'
| otherwise = errorBadFormat $ fmtChar fmt
where
fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }
instance (Pretty a) => Pretty (Maybe a) where
prettyPrec (Just a) p = prettyPrec a p
prettyPrec Nothing p = "<Nothing>"

182
src/GM.hs
View File

@@ -8,13 +8,8 @@ Description : The G-Machine
module GM module GM
( hdbgProg ( hdbgProg
, evalProg , evalProg
, evalProgR
, GmState(..)
, gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
, Node(..) , Node(..)
, showState
, gmEvalProg , gmEvalProg
, Stats(..)
, finalStateOf , finalStateOf
, resultOf , resultOf
, resultOfExpr , resultOfExpr
@@ -26,35 +21,23 @@ import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid (Endo(..)) import Data.Monoid (Endo(..))
import Data.Tuple (swap) import Data.Tuple (swap)
import Control.Lens import Lens.Micro
import Data.Text.Lens (IsText, packed, unpacked) import Lens.Micro.Extras (view)
import Lens.Micro.TH
import Lens.Micro.Platform (packed, unpacked)
import Lens.Micro.Platform.Internal (IsText(..))
import Text.Printf import Text.Printf
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Prettyprinter
import Data.Pretty
import System.IO (Handle, hPutStrLn) import System.IO (Handle, hPutStrLn)
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
import System.IO.Unsafe (unsafePerformIO)
import Data.String (IsString) import Data.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
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
tag_Unit_unit :: Int
tag_Unit_unit = 0
tag_Bool_True :: Int
tag_Bool_True = 1
tag_Bool_False :: Int
tag_Bool_False = 0
{-} {-}
hdbgProg = undefined hdbgProg = undefined
@@ -90,7 +73,6 @@ data Key = NameKey Name
| ConstrKey Tag Int | ConstrKey Tag Int
deriving (Show, Eq) deriving (Show, Eq)
-- >> [ref/Instr]
data Instr = Unwind data Instr = Unwind
| PushGlobal Name | PushGlobal Name
| PushConstr Tag Int | PushConstr Tag Int
@@ -105,14 +87,12 @@ data Instr = Unwind
-- arith -- arith
| Neg | Add | Sub | Mul | Div | Neg | Add | Sub | Mul | Div
-- comparison -- comparison
| Equals | Lesser | GreaterEq | Equals
| Pack Tag Int -- Pack Tag Arity | Pack Tag Int -- Pack Tag Arity
| CaseJump [(Tag, Code)] | CaseJump [(Tag, Code)]
| Split Int | Split Int
| Print
| Halt | Halt
deriving (Show, Eq) deriving (Show, Eq)
-- << [ref/Instr]
data Node = NNum Int data Node = NNum Int
| NAp Addr Addr | NAp Addr Addr
@@ -155,7 +135,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h res = resAddr >>= flip hLookup h
hdbgProg :: Program' -> Handle -> IO GmState hdbgProg :: Program' -> Handle -> IO (Node, Stats)
hdbgProg p hio = do hdbgProg p hio = do
(renderOut . showState) `traverse_` states (renderOut . showState) `traverse_` states
-- TODO: i'd like the statistics to be at the top of the file, but `sts` -- TODO: i'd like the statistics to be at the top of the file, but `sts`
@@ -163,9 +143,9 @@ hdbgProg p hio = do
-- *can't* get partial logs in the case of a crash. this is in opposition to -- *can't* get partial logs in the case of a crash. this is in opposition to
-- the above traversal which *will* produce partial logs. i love laziness :3 -- the above traversal which *will* produce partial logs. i love laziness :3
renderOut . showStats $ sts renderOut . showStats $ sts
pure final pure (res, sts)
where where
renderOut r = hPutStrLn hio $ show r ++ "\n" renderOut r = hPutStrLn hio $ render r ++ "\n"
states = eval $ compile p states = eval $ compile p
final = last states final = last states
@@ -176,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" $ show 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
@@ -230,38 +195,12 @@ step st = case head (st ^. gmCode) of
Mul -> mulI Mul -> mulI
Div -> divI Div -> divI
Equals -> equalsI Equals -> equalsI
Lesser -> lesserI
GreaterEq -> greaterEqI
Split n -> splitI n Split n -> splitI n
Pack t n -> packI t n Pack t n -> packI t n
CaseJump as -> caseJumpI as CaseJump as -> caseJumpI as
Print -> printI
Halt -> haltI Halt -> haltI
where where
printI :: GmState
printI = case hLookupUnsafe a h of
NNum n -> (evilTempPrinter `seq` st)
& gmCode .~ i
& gmStack .~ s
where
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
-- TODO: an actual output system
evilTempPrinter = unsafePerformIO (print n)
NConstr _ as -> st
& gmCode .~ i' ++ i
& gmStack .~ s'
where
i' = mconcat $ replicate n [Eval,Print]
n = length as
s' = as ++ s
where
h = st ^. gmHeap
(a:s) = st ^. gmStack
Print : i = st ^. gmCode
-- nuke the state -- nuke the state
haltI :: GmState haltI :: GmState
haltI = error "halt#" haltI = error "halt#"
@@ -455,10 +394,8 @@ step st = case head (st ^. gmCode) of
mulI = primitive2 boxInt unboxInt (*) st mulI = primitive2 boxInt unboxInt (*) st
divI = primitive2 boxInt unboxInt div st divI = primitive2 boxInt unboxInt div st
lesserI, greaterEqI, equalsI :: GmState equalsI :: GmState
equalsI = primitive2 boxBool unboxInt (==) st equalsI = primitive2 boxBool unboxInt (==) st
lesserI = primitive2 boxBool unboxInt (<) st
greaterEqI = primitive2 boxBool unboxInt (>=) st
splitI :: Int -> GmState splitI :: Int -> GmState
splitI n = st splitI n = st
@@ -600,13 +537,12 @@ boxBool st p = st
where where
h = st ^. gmHeap h = st ^. gmHeap
(h',a) = alloc h (NConstr p' []) (h',a) = alloc h (NConstr p' [])
p' = if p then tag_Bool_True else tag_Bool_False p' = if p then 1 else 0
unboxBool :: Addr -> GmState -> Bool unboxBool :: Addr -> GmState -> Bool
unboxBool a st = case hLookup a h of unboxBool a st = case hLookup a h of
Just (NConstr t []) Just (NConstr 1 []) -> True
| t == tag_Bool_True -> True Just (NConstr 0 []) -> False
| t == tag_Bool_False -> False
Just _ -> error "unboxInt received a non-int" Just _ -> error "unboxInt received a non-int"
Nothing -> error "unboxInt received an invalid address" Nothing -> error "unboxInt received an invalid address"
where h = st ^. gmHeap where h = st ^. gmHeap
@@ -642,10 +578,6 @@ compiledPrims =
, binop "*#" Mul , binop "*#" Mul
, binop "/#" Div , binop "/#" Div
, binop "==#" Equals , binop "==#" Equals
, binop "<#" Lesser
, binop ">=#" GreaterEq
, ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
, Unwind ])
] ]
where where
unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind]) unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -729,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!"
@@ -749,12 +680,14 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
mconcat binders <> compileE g' e <> [Slide d] mconcat binders <> compileE g' e <> [Slide d]
where where
d = length bs d = length bs
(g',binders) = mapAccumL compileBinder g bs (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
-- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> Binding' -> (Env, Code) compileBinder :: Env -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v) = (m',c) compileBinder m (k := v, a) = (m',c)
where where
m' = (NameKey k, 0) : argOffset 1 m m' = (NameKey k, a) : m
-- make note that we use m rather than m'! -- make note that we use m rather than m'!
c = compileC m v c = compileC m v
@@ -782,27 +715,21 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul a b compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul a b
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b
compileE g (">=#" :$ a :$ b) = inlineOp2 g GreaterEq a b
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
compileE g e = compileC g e ++ [Eval] compileE g e = compileC g e ++ [Eval]
compileD :: Env -> [Alter'] -> [(Tag, Code)] compileD :: Env -> [Alter'] -> [(Tag, Code)]
compileD g = fmap (compileA g) 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]
@@ -823,13 +750,13 @@ showCon t n = printf "Pack{%d %d}" t n ^. packed
pprTabstop :: Int pprTabstop :: Int
pprTabstop = 4 pprTabstop = 4
qquotes :: Doc ann -> Doc ann qquotes :: Doc -> Doc
qquotes d = "`" <> d <> "'" qquotes d = "`" <> d <> "'"
showStats :: Stats -> Doc ann showStats :: Stats -> Doc
showStats sts = "==== Stats ============" <> line <> stats showStats sts = "==== Stats ============" $$ stats
where where
stats = textt @String $ printf stats = text $ printf
"Reductions : %5d\n\ "Reductions : %5d\n\
\Prim Reductions : %5d\n\ \Prim Reductions : %5d\n\
\Allocations : %5d\n\ \Allocations : %5d\n\
@@ -839,10 +766,10 @@ showStats sts = "==== Stats ============" <> line <> stats
(sts ^. stsAllocations) (sts ^. stsAllocations)
(sts ^. stsGCCycles) (sts ^. stsGCCycles)
showState :: GmState -> Doc ann showState :: GmState -> Doc
showState st = vcat showState st = vcat
[ "==== GmState " <> int stnum <> " " [ "==== GmState " <> int stnum <> " "
<> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=') <> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
, "-- Next instructions -------" , "-- Next instructions -------"
, info $ showCodeShort c , info $ showCodeShort c
, "-- Stack -------------------" , "-- Stack -------------------"
@@ -859,23 +786,23 @@ showState st = vcat
-- indent data -- indent data
info = nest pprTabstop info = nest pprTabstop
showCodeShort :: Code -> Doc ann showCodeShort :: Code -> Doc
showCodeShort c = braces c' showCodeShort c = braces c'
where where
c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..." c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
| otherwise = list (showInstr <$> c) | otherwise = list (showInstr <$> c)
list = hcat . punctuate "; " list = hcat . punctuate "; "
showStackShort :: Stack -> Doc ann showStackShort :: Stack -> Doc
showStackShort s = brackets s' showStackShort s = brackets s'
where where
-- no access to heap, otherwise we'd use showNodeAt -- no access to heap, otherwise we'd use showNodeAt
s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..." s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
| otherwise = list (showEntry <$> s) | otherwise = list (showEntry <$> s)
list = hcat . punctuate ", " list = hcat . punctuate ", "
showEntry = textt . show showEntry = text . show
showStack :: GmState -> Doc ann showStack :: GmState -> Doc
showStack st = vcat $ uncurry showEntry <$> si showStack st = vcat $ uncurry showEntry <$> si
where where
h = st ^. gmHeap h = st ^. gmHeap
@@ -887,9 +814,10 @@ showStack st = vcat $ uncurry showEntry <$> si
w = maxWidth (addresses h) w = maxWidth (addresses h)
showIndex n = padInt w n <> ": " showIndex n = padInt w n <> ": "
showEntry :: Int -> Addr -> Doc
showEntry n a = showIndex n <> showNodeAt st a showEntry n a = showIndex n <> showNodeAt st a
showDump :: GmState -> Doc ann showDump :: GmState -> Doc
showDump st = vcat $ uncurry showEntry <$> di showDump st = vcat $ uncurry showEntry <$> di
where where
d = st ^. gmDump d = st ^. gmDump
@@ -898,13 +826,14 @@ showDump st = vcat $ uncurry showEntry <$> di
showIndex n = padInt w n <> ": " showIndex n = padInt w n <> ": "
w = maxWidth (fst <$> di) w = maxWidth (fst <$> di)
showEntry :: Int -> (Code, Stack) -> Doc
showEntry n (c,s) = showIndex n <> nest pprTabstop entry showEntry n (c,s) = showIndex n <> nest pprTabstop entry
where where
entry = vsep [ "Stack : " <> showCodeShort c entry = ("Stack : " <> showCodeShort c)
, "Code : " <> showStackShort s ] $$ ("Code : " <> showStackShort s)
padInt :: Int -> Int -> Doc ann padInt :: Int -> Int -> Doc
padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
maxWidth :: [Int] -> Int maxWidth :: [Int] -> Int
maxWidth ns = digitalWidth $ maximum ns maxWidth ns = digitalWidth $ maximum ns
@@ -912,7 +841,7 @@ maxWidth ns = digitalWidth $ maximum ns
digitalWidth :: Int -> Int digitalWidth :: Int -> Int
digitalWidth = length . show digitalWidth = length . show
showHeap :: GmState -> Doc ann showHeap :: GmState -> Doc
showHeap st = vcat $ showEntry <$> addrs showHeap st = vcat $ showEntry <$> addrs
where where
showAddr n = padInt w n <> ": " showAddr n = padInt w n <> ": "
@@ -921,12 +850,13 @@ showHeap st = vcat $ showEntry <$> addrs
h = st ^. gmHeap h = st ^. gmHeap
addrs = addresses h addrs = addresses h
showEntry :: Addr -> Doc
showEntry a = showAddr a <> showNodeAt st a showEntry a = showAddr a <> showNodeAt st a
showNodeAt :: GmState -> Addr -> Doc ann showNodeAt :: GmState -> Addr -> Doc
showNodeAt = showNodeAtP 0 showNodeAt = showNodeAtP 0
showNodeAtP :: Int -> GmState -> Addr -> Doc ann showNodeAtP :: Int -> GmState -> Addr -> Doc
showNodeAtP p st a = case hLookup a h of showNodeAtP p st a = case hLookup a h of
Just (NNum n) -> int n <> "#" Just (NNum n) -> int n <> "#"
Just (NGlobal _ _) -> textt name Just (NGlobal _ _) -> textt name
@@ -950,9 +880,9 @@ showNodeAtP p st a = case hLookup a h of
h = st ^. gmHeap h = st ^. gmHeap
pprec = maybeParens (p > 0) pprec = maybeParens (p > 0)
showSc :: GmState -> (Name, Addr) -> Doc ann showSc :: GmState -> (Name, Addr) -> Doc
showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
, code ] $$ code
where where
code = case hLookup a (st ^. gmHeap) of code = case hLookup a (st ^. gmHeap) of
Just (NGlobal _ c) -> showCode c Just (NGlobal _ c) -> showCode c
@@ -963,21 +893,19 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
errTxtInvalidObject = "<invalid object>" errTxtInvalidObject = "<invalid object>"
errTxtInvalidAddress = "<invalid address>" errTxtInvalidAddress = "<invalid address>"
showCode :: Code -> Doc ann showCode :: Code -> Doc
showCode c = "Code" <+> braces instrs showCode c = "Code" <+> braces instrs
where instrs = vcat $ showInstr <$> c where instrs = vcat $ showInstr <$> c
showInstr :: Instr -> Doc ann showInstr :: Instr -> Doc
showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ] showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
where where
showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
showInstr i = textt $ show i showInstr i = text $ show i
int = pretty textt :: (IsText a) => a -> Doc
textt t = t ^. unpacked & text
textt :: (Pretty a) => a -> Doc ann
textt = pretty
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------

17
src/Misc.hs
View File

@@ -1,17 +0,0 @@
module Misc where
--------------------------------------------------------------------------------
import Data.Functor.Classes
--------------------------------------------------------------------------------
showsTernaryWith :: (Int -> a -> ShowS)
-> (Int -> b -> ShowS)
-> (Int -> c -> ShowS)
-> String -> Int -> a -> b -> c -> ShowS
showsTernaryWith sp1 sp2 sp3 name d x y z
= showParen (d > 10)
$ showString name . showChar ' '
. sp1 11 x . showChar ' '
. sp2 11 y . showChar ' '
. sp3 11 z

13
src/Misc/CofreeF.hs
View File

@@ -1,13 +0,0 @@
{-# LANGUAGE PatternSynonyms #-}
module Misc.CofreeF
( pattern (:<$)
)
where
--------------------------------------------------------------------------------
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
import Control.Comonad.Trans.Cofree (CofreeF)
--------------------------------------------------------------------------------
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
pattern a :<$ b = a Trans.Cofree.:< b

54
src/Misc/Lift1.hs
View File

@@ -1,54 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Misc.Lift1
( Lift1(..), lift1
, liftCon, liftCon2, liftCon3
, Lift(..)
)
where
--------------------------------------------------------------------------------
import Language.Haskell.TH hiding (Type, Name)
import Language.Haskell.TH.Syntax hiding (Type, Name)
import Language.Haskell.TH.Syntax qualified as TH
import Language.Haskell.TH.Quote
import Data.Kind qualified
import GHC.Generics
-- instances
import Data.Fix
import Data.Functor.Sum
--------------------------------------------------------------------------------
class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
-- lift1 :: (Quote m, Lift t) => f t -> m Exp
liftLift :: (Quote m) => (a -> m Exp) -> f a -> m Exp
lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
lift1 = liftLift lift
liftCon :: Quote m => TH.Name -> m Exp -> m Exp
liftCon n = fmap (AppE (ConE n))
liftCon2 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp
liftCon2 n a b = do
a' <- a
b' <- b
pure $ ConE n `AppE` a' `AppE` b'
liftCon3 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp -> m Exp
liftCon3 n a b c = do
a' <- a
b' <- b
c' <- c
pure $ ConE n `AppE` a' `AppE` b' `AppE` c'
instance Lift1 f => Lift (Fix f) where
lift (Fix f) = AppE (ConE 'Fix) <$> lift1 f
instance Lift1 [] where
liftLift lf [] = pure $ ConE '[]
liftLift lf (a:as) = liftCon2 '(:) (lf a) (liftLift lf as)
instance (Lift1 f, Lift1 g) => Lift1 (Sum f g) where
liftLift lf (InL fa) = liftCon 'InL $ liftLift lf fa
liftLift lf (InR ga) = liftCon 'InR $ liftLift lf ga

59
src/RLP/Syntax.hs Normal file
View File

@@ -0,0 +1,59 @@
{-# LANGUAGE OverloadedStrings #-}
module RLP.Syntax
( RlpExpr
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Lens.Micro
import Core (HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
newtype RlpProgram b = RlpProgram [Decl b]
data Decl b = InfixD InfixAssoc Int VarId
| FunD VarId [Pat b] (RlpExpr b)
| DataD ConId [ConId] [ConAlt]
data ConAlt = ConAlt ConId [ConId]
data InfixAssoc = Assoc | AssocL | AssocR
data RlpExpr b = LetE [Bind b] (RlpExpr b)
| VarE VarId
| ConE ConId
| LamE [Pat b] (RlpExpr b)
| CaseE (RlpExpr b) [Alt b]
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b)
| AppE (RlpExpr b) (RlpExpr b)
| LitE (Lit b)
-- do we want guards?
data Alt b = AltA (Pat b) (RlpExpr b)
data Bind b = PatB (Pat b) (RlpExpr b)
| FunB VarId [Pat b] (RlpExpr b)
data VarId = NameVar Text
| SymVar Text
data ConId = NameCon Text
| SymCon Text
data Pat b = VarP VarId
| LitP (Lit b)
| ConP ConId [Pat b]
data Lit b = IntL Int
| CharL Char
| ListL [RlpExpr b]
-- instance HasLHS Alt Alt Pat Pat where
-- _lhs = lens
-- (\ (AltA p _) -> p)
-- (\ (AltA _ e) p' -> AltA p' e)
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
-- _rhs = lens
-- (\ (AltA _ e) -> e)
-- (\ (AltA p _) e' -> AltA p e')

243
src/Rlp/AltParse.y
View File

@@ -1,243 +0,0 @@
{
module Rlp.AltParse
( parseRlpProg
, parseRlpProgR
, parseRlpExprR
, runP'
)
where
import Data.List.Extra
import Data.Text (Text)
import Control.Comonad
import Control.Comonad.Cofree
import Control.Lens hiding (snoc)
import Compiler.RlpcError
import Compiler.RLPC
import Control.Monad.Errorful
import Rlp.Lex
import Rlp.AltSyntax
import Rlp.Parse.Types hiding (PsName)
import Core.Syntax qualified as Core
}
%name parseRlpProg StandaloneProgram
%name parseRlpExpr StandaloneExpr
%monad { P }
%lexer { lexCont } { Located _ TokenEOF }
%error { parseError }
%errorhandlertype explist
%tokentype { Located RlpToken }
%token
varname { Located _ (TokenVarName _) }
conname { Located _ (TokenConName _) }
consym { Located _ (TokenConSym _) }
varsym { Located _ (TokenVarSym _) }
data { Located _ TokenData }
case { Located _ TokenCase }
of { Located _ TokenOf }
litint { Located _ (TokenLitInt _) }
'=' { Located _ TokenEquals }
'|' { Located _ TokenPipe }
'::' { Located _ TokenHasType }
';' { Located _ TokenSemicolon }
'λ' { Located _ TokenLambda }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'->' { Located _ TokenArrow }
vsemi { Located _ TokenSemicolonV }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
vlbrace { Located _ TokenLBraceV }
vrbrace { Located _ TokenRBraceV }
infixl { Located _ TokenInfixL }
infixr { Located _ TokenInfixR }
infix { Located _ TokenInfix }
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
in { Located _ TokenIn }
forall { Located _ TokenForall }
%nonassoc '='
%right '->'
%right in
%%
StandaloneProgram :: { Program Name (RlpExpr PsName) }
: layout0(Decl) { Program $1 }
StandaloneExpr :: { RlpExpr PsName }
: VL Expr VR { $2 }
VL :: { () }
VL : vlbrace { () }
VR :: { () }
VR : vrbrace { () }
| error { () }
VS :: { () }
VS : ';' { () }
| vsemi { () }
Decl :: { Decl PsName (RlpExpr PsName) }
: FunD { $1 }
| DataD { $1 }
| TySigD { $1 }
TySigD :: { Decl PsName (RlpExpr PsName) }
: Var '::' Type { TySigD $1 $3 }
DataD :: { Decl PsName (RlpExpr PsName) }
: data Con TyVars { DataD $2 $3 [] }
| data Con TyVars '=' DataCons { DataD $2 $3 $5 }
DataCons :: { [DataCon PsName] }
: DataCon '|' DataCons { $1 : $3 }
| DataCon { [$1] }
DataCon :: { DataCon PsName }
: Con list0(Type1) { DataCon $1 $2 }
Type1 :: { Type PsName }
: varname { VarT $ extractVarName $1 }
| Con { ConT $1 }
| '(' Type ')' { $2 }
Type :: { Type PsName }
: Type '->' Type { $1 :-> $3 }
| AppT { $1 }
AppT :: { Type PsName }
: Type1 { $1 }
| AppT Type1 { AppT $1 $2 }
TyVars :: { [PsName] }
: list0(varname) { $1 <&> view ( to extract
. singular _TokenVarName ) }
FunD :: { Decl PsName (RlpExpr PsName) }
: Var Pat1s '=' Expr { FunD $1 $2 $4 }
Expr :: { RlpExpr PsName }
: AppE { $1 }
| LetE { $1 }
| CaseE { $1 }
| LamE { $1 }
LamE :: { RlpExpr PsName }
: 'λ' list0(varname) '->' Expr { Finl $ Core.LamF (fmap extractName $2) $4 }
CaseE :: { RlpExpr PsName }
: case Expr of CaseAlts { Finr $ CaseEF $2 $4 }
CaseAlts :: { [Alter PsName (RlpExpr PsName)] }
: layout1(CaseAlt) { $1 }
CaseAlt :: { Alter PsName (RlpExpr PsName) }
: Pat '->' Expr { Alter $1 $3 }
LetE :: { RlpExpr PsName }
: let layout1(Binding) in Expr
{ Finr $ LetEF Core.NonRec $2 $4 }
| letrec layout1(Binding) in Expr
{ Finr $ LetEF Core.Rec $2 $4 }
Binding :: { Binding PsName (RlpExpr PsName) }
: Pat '=' Expr { VarB $1 $3 }
Expr1 :: { RlpExpr PsName }
: VarE { $1 }
| litint { $1 ^. to extract
. singular _TokenLitInt
. to (Finl . Core.LitF . Core.IntL) }
| '(' Expr ')' { $2 }
| ConE { $1 }
AppE :: { RlpExpr PsName }
: AppE Expr1 { Finl $ Core.AppF $1 $2 }
| Expr1 { $1 }
VarE :: { RlpExpr PsName }
: Var { Finl $ Core.VarF $1 }
ConE :: { RlpExpr PsName }
: Con { Finl $ Core.VarF $1 }
Pat1s :: { [Pat PsName] }
: list0(Pat1) { $1 }
Pat1 :: { Pat PsName }
: Var { VarP $1 }
| Con { ConP $1 }
| '(' Pat ')' { $2 }
Pat :: { Pat PsName }
: AppP { $1 }
AppP :: { Pat PsName }
: Pat1 { $1 }
| AppP Pat1 { $1 `AppP` $2 }
Con :: { PsName }
: conname { $1 ^. to extract
. singular _TokenConName }
| '(' consym ')' { $1 ^. to extract
. singular _TokenConSym }
Var :: { PsName }
: varname { $1 ^. to extract
. singular _TokenVarName }
| '(' varsym ')' { $2 ^. to extract
. singular _TokenVarSym }
-- list0(p : α) : [α]
list0(p) : {- epsilon -} { [] }
| list0(p) p { $1 `snoc` $2 }
-- layout0(p : β) :: [β]
layout0(p) : '{' '}' { [] }
| VL VR { [] }
| layout1(p) { $1 }
-- layout_list0(sep : α, p : β) :: [β]
layout_list0(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
| {- epsilon -} { [] }
-- layout1(p : β) :: [β]
layout1(p) : '{' layout_list1(';',p) '}' { $2 }
| VL layout_list1(VS,p) VS VR { $2 }
| VL layout_list1(VS,p) VR { $2 }
-- layout_list1(sep : α, p : β) :: [β]
layout_list1(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
{
extractVarName = view $ to extract . singular _TokenVarName
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program Name (RlpExpr PsName))
parseRlpProgR s = liftErrorful $ errorful (ma,es)
where
(_,es,ma) = runP' parseRlpProg s
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr PsName)
parseRlpExprR s = liftErrorful $ errorful (ma,es)
where
(_,es,ma) = runP' parseRlpExpr s
parseError :: (Located RlpToken, [String]) -> P a
parseError (Located ss t,ts) = addFatalHere (ss ^. srcSpanLen) $
RlpParErrUnexpectedToken t ts
extractName = view $ to extract . singular _TokenVarName
}

301
src/Rlp/AltSyntax.hs
View File

@@ -1,301 +0,0 @@
{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}
module Rlp.AltSyntax
(
-- * AST
Program(..), Decl(..), ExprF(..), Pat(..)
, RlpExprF, RlpExpr, Binding(..), Alter(..)
, RlpExpr', RlpExprF', AnnotatedRlpExpr', Type'
, DataCon(..), Type(..), Kind
, pattern IntT, pattern TypeT
, Core.Rec(..)
, AnnotatedRlpExpr, TypedRlpExpr
, TypeF(..)
, Core.Name, PsName
, pattern (Core.:->)
-- * Optics
, programDecls
, _VarP, _FunB, _VarB
, _TySigD, _FunD
, _LetEF
, Core.applicants1, Core.arrowStops
-- * Functor-related tools
, Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
-- * Misc
, serialiseCofree
)
where
--------------------------------------------------------------------------------
import Data.Functor.Sum
import Control.Comonad.Cofree
import Data.Fix hiding (cata)
import Data.Functor.Foldable
import Data.Function (fix)
import GHC.Generics ( Generic, Generic1
, Generically(..), Generically1(..))
import Data.Hashable
import Data.Hashable.Lifted
import GHC.Exts (IsString)
import Control.Lens hiding ((.=))
import Data.Functor.Extend
import Data.Functor.Foldable.TH
import Text.Show.Deriving
import Data.Eq.Deriving
import Data.Text qualified as T
import Data.Aeson
import Data.Pretty
import Misc.Lift1
import Compiler.Types
import Core.Syntax qualified as Core
--------------------------------------------------------------------------------
type RlpExpr' = RlpExpr PsName
type RlpExprF' = RlpExprF PsName
type AnnotatedRlpExpr' = Cofree (RlpExprF PsName)
type Type' = Type PsName
type AnnotatedRlpExpr b = Cofree (RlpExprF b)
type TypedRlpExpr b = Cofree (RlpExprF b) (Type b)
type PsName = T.Text
newtype Program b a = Program [Decl b a]
deriving (Show, Functor, Foldable, Traversable)
instance Extend (Decl b) where
extended c w@(FunD n as a) = FunD n as (c w)
extended _ (DataD n as cs) = DataD n as cs
extended _ (TySigD n t) = TySigD n t
programDecls :: Iso (Program b a) (Program b' a') [Decl b a] [Decl b' a']
programDecls = iso sa bt where
sa (Program ds) = ds
bt = Program
data Decl b a = FunD b [Pat b] a
| DataD Core.Name [Core.Name] [DataCon b]
| TySigD Core.Name (Type b)
deriving (Show, Functor, Foldable, Traversable)
data DataCon b = DataCon Core.Name [Type b]
deriving (Show, Generic)
data Type b = VarT Core.Name
| ConT Core.Name
| AppT (Type b) (Type b)
| FunT
| ForallT b (Type b)
deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
instance Core.HasApplicants1 (Type b) (Type b) (Type b) (Type b) where
applicants1 k (AppT f x) = AppT <$> Core.applicants1 k f <*> k x
applicants1 k t = k t
instance (Hashable b) => Hashable (Type b)
pattern IntT :: (IsString b, Eq b) => Type b
pattern IntT = ConT "Int#"
type Kind = Type
pattern TypeT :: (IsString b, Eq b) => Type b
pattern TypeT = ConT "Type"
instance Core.HasArrowSyntax (Type b) (Type b) (Type b) where
_arrowSyntax = prism make unmake where
make (s,t) = FunT `AppT` s `AppT` t
unmake (FunT `AppT` s `AppT` t) = Right (s,t)
unmake s = Left s
data ExprF b a = InfixEF b a a
| LetEF Core.Rec [Binding b a] a
| CaseEF a [Alter b a]
deriving (Functor, Foldable, Traversable)
deriving (Eq, Generic, Generic1)
data Alter b a = Alter (Pat b) a
deriving (Show, Functor, Foldable, Traversable)
deriving (Eq, Generic, Generic1)
data Binding b a = FunB b [Pat b] a
| VarB (Pat b) a
deriving (Show, Functor, Foldable, Traversable)
deriving (Eq, Generic, Generic1)
-- type Expr b = Cofree (ExprF b)
type RlpExprF b = Sum (Core.ExprF b) (ExprF b)
type RlpExpr b = Fix (RlpExprF b)
data Pat b = VarP b
| ConP b
| AppP (Pat b) (Pat b)
deriving (Eq, Show, Generic, Generic1)
deriveShow1 ''Alter
deriveShow1 ''Binding
deriveShow1 ''ExprF
deriving instance (Show b, Show a) => Show (ExprF b a)
pattern Finl :: f (Fix (Sum f g)) -> Fix (Sum f g)
pattern Finl fa = Fix (InL fa)
pattern Finr :: g (Fix (Sum f g)) -> Fix (Sum f g)
pattern Finr ga = Fix (InR ga)
--------------------------------------------------------------------------------
instance (Out b, Out a) => Out (ExprF b a) where
outPrec = outPrec1
instance (Out b, Out a) => Out (Alter b a) where
outPrec = outPrec1
instance (Out b) => Out1 (Alter b) where
liftOutPrec pr _ (Alter p e) =
hsep [ out p, "->", pr 0 e]
instance Out b => Out1 (ExprF b) where
liftOutPrec pr p (InfixEF o a b) = maybeParens (p>0) $
pr 1 a <+> out o <+> pr 1 b
liftOutPrec pr p (CaseEF e as) = maybeParens (p>0) $
vsep [ hsep [ "case", pr 0 e, "of" ]
, nest 2 (vcat $ liftOutPrec pr 0 <$> as) ]
liftOutPrec pr p (LetEF r bs e) = maybeParens (p>0) $
vsep [ hsep [ letword r, "<bs>" ]
, nest 2 (hsep [ "in", pr 0 e ]) ]
where
letword Core.Rec = "letrec"
letword Core.NonRec = "let"
instance (Out b, Out a) => Out (Decl b a) where
outPrec = outPrec1
instance (Out b) => Out1 (Decl b) where
liftOutPrec pr _ (FunD f as e) =
hsep [ ttext f, hsep (outPrec appPrec1 <$> as)
, "=", pr 0 e ]
liftOutPrec _ _ (DataD f as []) =
hsep [ "data", ttext f, hsep (out <$> as) ]
liftOutPrec _ _ (DataD f as ds) =
hsep [ "data", ttext f, hsep (out <$> as), cons ]
where
cons = vcat $ zipWith (<+>) delims (out <$> ds)
delims = "=" : repeat "|"
liftOutPrec _ _ (TySigD n t) =
hsep [ ttext n, ":", out t ]
instance (Out b) => Out (DataCon b) where
out (DataCon n as) = ttext n <+> hsep (outPrec appPrec1 <$> as)
collapseForalls :: Prism' (Type b) ([b], Type b)
collapseForalls = prism' up down where
up (bs,m) = foldr ForallT m bs
down (ForallT x m) = case down m of
Just (xs,m') -> Just (x : xs, m')
Nothing -> Just ([x],m)
down _ = Nothing
-- (->) is given prec `appPrec-1`
instance (Out b) => Out (Type b) where
outPrec _ (VarT n) = ttext n
outPrec _ (ConT n) = ttext n
outPrec p (s Core.:-> t) = maybeParens (p>arrPrec) $
hsep [ outPrec arrPrec1 s, "->", outPrec arrPrec t ]
where arrPrec = appPrec-1
arrPrec1 = appPrec
outPrec p (AppT f x) = maybeParens (p>appPrec) $
outPrec appPrec f <+> outPrec appPrec1 x
outPrec p FunT = maybeParens (p>0) "->"
outPrec p t@(ForallT _ _) = maybeParens (p>0) $
t ^. singular collapseForalls & \(bs,m) ->
let bs' = "∀" <> (hsep $ outPrec appPrec1 <$> bs) <> "."
in bs' <+> outPrec 0 m
instance (Out b) => Out (Pat b) where
outPrec p (VarP b) = outPrec p b
outPrec p (ConP b) = outPrec p b
outPrec p (AppP c x) = maybeParens (p>appPrec) $
outPrec appPrec c <+> outPrec appPrec1 x
instance (Out a, Out b) => Out (Program b a) where
outPrec = outPrec1
instance (Out b) => Out1 (Program b) where
liftOutPrec pr p (Program ds) = vsep $ liftOutPrec pr p <$> ds
makePrisms ''ExprF
makePrisms ''Pat
makePrisms ''Binding
makePrisms ''Decl
deriving instance (Lift b, Lift a) => Lift (Program b a)
deriving instance (Lift b, Lift a) => Lift (Decl b a)
deriving instance (Lift b) => Lift (Pat b)
deriving instance (Lift b) => Lift (DataCon b)
deriving instance (Lift b) => Lift (Type b)
instance Lift b => Lift1 (Binding b) where
liftLift lf (VarB b a) = liftCon2 'VarB (lift b) (lf a)
instance Lift b => Lift1 (Alter b) where
liftLift lf (Alter b a) = liftCon2 'Alter (lift b) (lf a)
instance Lift b => Lift1 (ExprF b) where
liftLift lf (InfixEF o a b) =
liftCon3 'InfixEF (lift o) (lf a) (lf b)
liftLift lf (LetEF r bs e) =
liftCon3 'LetEF (lift r) bs' (lf e)
where bs' = liftLift (liftLift lf) bs
liftLift lf (CaseEF e as) =
liftCon2 'CaseEF (lf e) as'
where as' = liftLift (liftLift lf) as
deriveEq1 ''Binding
deriveEq1 ''Alter
deriveEq1 ''ExprF
instance (Hashable b) => Hashable (Pat b)
instance (Hashable b, Hashable a) => Hashable (Binding b a)
instance (Hashable b, Hashable a) => Hashable (Alter b a)
instance (Hashable b, Hashable a) => Hashable (ExprF b a)
instance (Hashable b) => Hashable1 (Alter b)
instance (Hashable b) => Hashable1 (Binding b)
instance (Hashable b) => Hashable1 (ExprF b)
makeBaseFunctor ''Type
instance Core.HasArrowStops (Type b) (Type b) (Type b) (Type b) where
arrowStops k (s Core.:-> t) = (Core.:->) <$> k s <*> Core.arrowStops k t
arrowStops k t = k t
deriving via (Generically1 Pat)
instance ToJSON1 Pat
deriving via (Generically (Pat b))
instance ToJSON b => ToJSON (Pat b)
deriving via (Generically1 (Alter b))
instance ToJSON b => ToJSON1 (Alter b)
deriving via (Generically1 (Binding b))
instance ToJSON b => ToJSON1 (Binding b)
deriving via (Generically1 (ExprF b))
instance ToJSON b => ToJSON1 (ExprF b)
deriving via (Generically1 (RlpExprF b))
instance ToJSON b => ToJSON1 (RlpExprF b)
serialiseCofree :: (Functor f, ToJSON1 f, ToJSON a) => Cofree f a -> Value
serialiseCofree = cata \case
ann :<$ e -> object [ "ann" .= ann
, "val" .= toJSON1 e ]

324
src/Rlp/HindleyMilner.hs
View File

@@ -1,324 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Rlp.HindleyMilner
( typeCheckRlpProgR
, TypeError(..)
, renamePrettily
)
where
--------------------------------------------------------------------------------
import Control.Lens hiding (Context', Context, (:<), para, uncons)
import Control.Lens.Unsound
import Control.Lens.Extras
import Control.Monad.Errorful
import Control.Monad.State
import Control.Monad.Accum
import Control.Monad.Reader
import Control.Monad
import Control.Monad.Extra
import Control.Arrow ((>>>))
import Control.Monad.Writer.Strict
import Data.List
import Data.Monoid
import Data.Text qualified as T
import Data.Foldable (fold)
import Data.Function
import Data.Foldable
import Data.Pretty hiding (annotate)
import Data.Maybe
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Data.HashSet (HashSet)
import Data.HashSet.Lens
import Data.HashSet qualified as S
import Data.Maybe (fromMaybe)
import Data.Traversable
import GHC.Generics (Generic, Generically(..))
import Debug.Trace
import Data.Functor hiding (unzip)
import Data.Functor.Extend
import Data.Functor.Foldable hiding (fold)
import Data.Fix hiding (cata, para, cataM)
import Control.Comonad.Cofree
import Control.Comonad
import Effectful
import Compiler.RLPC
import Compiler.RlpcError
import Rlp.AltSyntax as Rlp
import Core.Syntax qualified as Core
import Core.Syntax (ExprF(..), Lit(..))
import Rlp.HindleyMilner.Types
--------------------------------------------------------------------------------
-- | Annotate a structure with the result of a catamorphism at each level.
--
-- Pretentious etymology: 'dendr-' means 'tree'
dendroscribe :: (Functor f, Base t ~ f, Recursive t)
=> (f (Cofree f a) -> a) -> t -> Cofree f a
dendroscribe c (project -> f) = c f' :< f'
where f' = dendroscribe c <$> f
dendroscribeM :: (Traversable f, Monad m, Base t ~ f, Recursive t)
=> (f (Cofree f a) -> m a) -> t -> m (Cofree f a)
dendroscribeM c (project -> f) = do
as <- dendroscribeM c `traverse` f
a <- c as
pure (a :< as)
--------------------------------------------------------------------------------
assume :: Name -> Type' -> Judgement
assume n t = mempty & assumptions .~ H.singleton n [t]
equal :: Type' -> Type' -> Judgement
equal a b = mempty & constraints .~ [Equality a b]
elim :: Name -> Type' -> Judgement -> Judgement
elim n t j = j & assumptions %~ H.delete n
& constraints <>~ cs
where
cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
[Equality t t']
elimGenerally :: Name -> Type' -> Judgement -> Judgement
elimGenerally n t j = j & assumptions %~ H.delete n
& constraints <>~ cs
where
cs = j & foldMapOf (assumptions . at n . each . each) \t' ->
[ImplicitInstance mempty t' t]
monomorphise :: Type' -> Judgement -> Judgement
monomorphise n = constraints . each . _ImplicitInstance . _1 %~ S.insert n
withoutPatterns :: [Binding b a] -> [(b, a)]
withoutPatterns bs = bs ^.. each . singular _VarB
& each . _1 %~ view (singular _VarP)
--------------------------------------------------------------------------------
gather :: (Unique :> es)
=> RlpExprF' (Type', Judgement) -> Eff es (Type', Judgement)
gather (InL (LitF (IntL _))) = pure (IntT, mempty)
gather (InL (VarF n)) = do
t <- freshTv
pure (t, assume n t)
gather (InL (AppF (tf,jf) (tx,jx))) = do
tfx <- freshTv
pure (tfx, jf <> jx <> equal tf (tx :-> tfx))
gather (InL (LamF xs (te,je))) = do
bs <- for xs (\x -> (x,) <$> freshTv)
let j = je & forBinds elim bs
& forBinds (const monomorphise) bs
t = foldr (:->) te (bs ^.. each . _2)
pure (t, j)
where
elimBind (x,tx) j1 = elim x tx j1
gather (InR (LetEF NonRec (withoutPatterns -> bs) (te,je))) = do
let j = foldr elimBind je bs
pure (te, j)
where
elimBind (x,(tx,jx)) j1 = elimGenerally x tx (jx <> j1)
gather (InR (LetEF Rec (withoutPatterns -> bs) (te,je))) = do
let j = foldOf (each . _2 . _2) bs
j' = foldr elimRecBind j bs
pure (te, j' <> foldr elimBind je bs)
where
elimRecBind (x,(tx,_)) j = elim x tx j
elimBind (x,(tx,_)) j = elimGenerally x tx j
forBinds :: (PsName -> Type' -> Judgement -> Judgement)
-> [(PsName, Type')] -> Judgement -> Judgement
forBinds f bs j = foldr (uncurry f) j bs
unify :: (Unique :> es)
=> [Constraint] -> ErrorfulT TypeError (Eff es) Subst
unify [] = pure id
unify (c:cs) = case c of
Equality (ConT a) (ConT b)
| a == b
-> unify cs
Equality (VarT a) (VarT b)
| a == b
-> unify cs
Equality (VarT a) t
| a `occurs` t
-> error "recursive type"
| otherwise
-> unify (subst a t <$> cs) <&> (. subst a t)
Equality t (VarT a)
-> unify (Equality (VarT a) t : cs)
Equality (s :-> t) (s' :-> t')
-> unify (Equality s s' : Equality t t' : cs)
ImplicitInstance m s t
| null $ (freeTvs t `S.difference` freeTvs m)
`S.intersection` activeTvs cs
-> unify $ ExplicitInstance s (generalise (freeTvs m) t) : cs
ExplicitInstance s t -> do
t' <- lift $ instantiate t
unify $ Equality s t' : cs
Equality a b
-> addFatal $ TyErrCouldNotUnify a b
_ -> error $ "explode (typecheckr explsiong): " <> show c
activeTvs :: [Constraint] -> HashSet Name
activeTvs = foldMap \case
Equality s t -> freeTvs s <> freeTvs t
ImplicitInstance m s t -> freeTvs s <> (freeTvs m `S.intersection` freeTvs t)
ExplicitInstance s t -> freeTvs s <> freeTvs t
instantiate :: (Unique :> es) => Scheme -> Eff es Type'
instantiate (ForallT x t) = do
x' <- freshTv
subst x x' <$> instantiate t
instantiate t = pure t
generalise :: HashSet Name -> Type' -> Scheme
generalise m t = foldr ForallT t as
where as = S.toList $ freeTvs t `S.difference` m
occurs :: (HasTypes a) => Name -> a -> Bool
occurs x t = x `elem` freeTvs t
--------------------------------------------------------------------------------
annotate :: (Unique :> es)
=> RlpExpr' -> Eff es (Cofree RlpExprF' (Type', Judgement))
annotate = dendroscribeM (gather . fmap extract)
orderConstraints :: [Constraint] -> [Constraint]
orderConstraints cs = a <> b
where (a,b) = partition (isn't _ImplicitInstance) cs
finalJudgement :: Cofree RlpExprF' (Type', Judgement) -> Judgement
finalJudgement = snd . extract
solveTree :: (Unique :> es)
=> Cofree RlpExprF' (Type', Judgement)
-> ErrorfulT TypeError (Eff es) (Cofree RlpExprF' Type')
solveTree e = do
sub <- unify (orderConstraints $ finalJudgement e ^. constraints . reversed)
pure $ sub . view _1 <$> e
solveJudgement :: (Unique :> es)
=> Judgement
-> ErrorfulT TypeError (Eff es) Subst
solveJudgement j = unify (orderConstraints $ j ^. constraints . reversed)
typeCheckRlpProgR :: Monad m
=> Program PsName RlpExpr'
-> RLPCT m (Program PsName (Cofree RlpExprF' Type'))
typeCheckRlpProgR
= liftErrorful
. hoistErrorfulT (pure . runPureEff . runUnique)
. mapErrorful (errorMsg (SrcSpan 0 0 0 0))
. inferProg
finallyGeneralise :: Cofree RlpExprF' Type' -> Cofree RlpExprF' Type'
finallyGeneralise = _extract %~ generalise mempty
inferProg :: (Unique :> es)
=> Program PsName RlpExpr'
-> ErrorfulT TypeError (Eff es)
(Program PsName (Cofree RlpExprF' Type'))
inferProg p = do
p' <- lift $ annotateProg (etaExpandProg p)
sub <- solveJudgement (foldOf (folded . _extract . _2) p')
pure $ p' & traversed . traversed %~ sub . view _1
& traversed %~ finallyGeneralise
etaExpandProg :: Program PsName RlpExpr' -> Program PsName RlpExpr'
etaExpandProg = programDecls . each %~ etaExpand where
etaExpand (FunD n [] e) = FunD n [] e
etaExpand (FunD n as e) = FunD n [] $ Finl (LamF as' e)
where as' = as ^.. each . singular _VarP
etaExpand x = x
infer :: (Unique :> es)
=> RlpExpr'
-> ErrorfulT TypeError (Eff es)
(Cofree RlpExprF' Type')
infer e = do
e' <- solveTree <=< (lift . annotate) $ e
pure $ finallyGeneralise e'
annotateDefs :: (Unique :> es)
=> Program PsName RlpExpr'
-> Eff es (Program PsName
(Cofree RlpExprF' (Type', Judgement)))
annotateDefs = traverseOf (programDefs . _2) annotate
annotateProg :: (Unique :> es)
=> Program PsName RlpExpr'
-> Eff es (Program PsName
(Cofree RlpExprF' (Type', Judgement)))
annotateProg p = do
p' <- annotateDefs p
let bs = p' ^.. programDefs & each . _2 %~ (fst . extract)
p'' = p' & programDefs . _2 . traversed . _2
%~ forBinds elimGenerally bs
pure p''
programDefs :: Traversal (Program b a) (Program b a') (b, a) (b, a')
programDefs k (Program ds) = Program <$> go k ds where
go k [] = pure []
go k (FunD n as e : ds) = (:) <$> refun as (k (n,e)) <*> go k ds
refun as kne = uncurry (\a b -> FunD a as b) <$> kne
--------------------------------------------------------------------------------
renamePrettily' :: Type PsName -> Type PsName
renamePrettily' = join renamePrettily
-- | for some type, compute a substitution which will rename all free variables
-- for aesthetic purposes
renamePrettily :: Type PsName -> Type PsName -> Type PsName
renamePrettily root = (`evalState` alphabetNames) . (renameFree <=< renameBound)
where
renameBound :: Type PsName -> State [PsName] (Type PsName)
renameBound = cata \case
ForallTF x m -> do
n <- getName
ForallT n <$> (subst x (VarT n) <$> m)
t -> embed <$> sequenceA t
renameFree :: Type PsName -> State [PsName] (Type PsName)
renameFree t = do
subs <- forM (freeVariablesLTR root) $ \v -> do
n <- getName
pure $ Endo (subst v (VarT n))
pure . appEndo (fold subs) $ t
getName :: State [PsName] PsName
getName = state (fromJust . uncons)
alphabetNames :: [PsName]
alphabetNames = alphabet ++ concatMap appendAlphabet alphabetNames
where alphabet = [ T.pack [c] | c <- ['a'..'z'] ]
appendAlphabet c = [ c <> c' | c' <- alphabet ]
freeVariablesLTR :: Type PsName -> [PsName]
freeVariablesLTR = nub . cata \case
VarTF x -> [x]
ForallTF x m -> m \\ [x]
vs -> concat vs

175
src/Rlp/HindleyMilner/Types.hs
View File

@@ -1,175 +0,0 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TemplateHaskell #-}
module Rlp.HindleyMilner.Types
where
--------------------------------------------------------------------------------
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Data.HashSet (HashSet)
import Data.HashSet qualified as S
import GHC.Generics (Generic(..), Generically(..))
import Data.Kind qualified
import Data.Text qualified as T
import Effectful.State.Static.Local
import Effectful.Labeled
import Effectful
import Text.Printf
import Data.Pretty
import Data.Function
import Control.Lens hiding (Context', Context, para)
import Data.Functor.Foldable hiding (fold)
import Data.Foldable
import Compiler.RlpcError
import Rlp.AltSyntax
--------------------------------------------------------------------------------
-- | A polymorphic type
type Scheme = Type'
type Subst = Type' -> Type'
data Constraint = Equality Type' Type'
| ImplicitInstance (HashSet Type') Type' Type'
| ExplicitInstance Type' Scheme
deriving Show
instance Out Constraint where
out (Equality s t) =
hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
--------------------------------------------------------------------------------
-- | Type error enum.
data TypeError
-- | Two types could not be unified
= TyErrCouldNotUnify Type' Type'
-- | @x@ could not be unified with @t@ because @x@ occurs in @t@
| TyErrRecursiveType Name Type'
-- | Untyped, potentially undefined variable
| TyErrUntypedVariable Name
| TyErrMissingTypeSig Name
| TyErrNonHomogenousCaseAlternatives (RlpExpr PsName)
deriving (Show)
instance IsRlpcError TypeError where
liftRlpcError = \case
-- todo: use anti-parser instead of show
TyErrCouldNotUnify t u -> Text
[ T.pack $ printf "Could not match type `%s` with `%s`."
(rout @String t) (rout @String u)
, "Expected: " <> rout t
, "Got: " <> rout u
]
TyErrUntypedVariable n -> Text
[ "Untyped (likely undefined) variable `" <> n <> "`"
]
TyErrRecursiveType t x -> Text
[ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
(rout @String t) (rout @String x)
]
--------------------------------------------------------------------------------
type Unique = State Int
runUnique :: Eff (Unique : es) a -> Eff es a
runUnique = evalState 0
freshTv :: (Unique :> es) => Eff es (Type PsName)
freshTv = do
n <- get
modify @Int succ
pure (VarT $ tvNameOfInt n)
tvNameOfInt :: Int -> PsName
tvNameOfInt n = "$a" <> T.pack (show n)
--------------------------------------------------------------------------------
-- | A 'Judgement' is a sort of "co-context" used in bottom-up inference. The
-- typical algorithms J, W, and siblings pass some context Γ to the inference
-- algorithm which is used to lookup variables and such. Here in rlpc we
-- infer a type under zero context; inference returns the assumptions made of
-- a variable which may be later eliminated and solved.
data Judgement = Judgement
{ _constraints :: [Constraint]
, _assumptions :: Assumptions
}
deriving (Show)
type Assumptions = HashMap PsName [Type PsName]
instance Semigroup Judgement where
a <> b = Judgement
{ _constraints = ((<>) `on` _constraints) a b
, _assumptions = (H.unionWith (<>) `on` _assumptions) a b
}
instance Monoid Judgement where
mempty = Judgement
{ _constraints = mempty
, _assumptions = mempty
}
--------------------------------------------------------------------------------
class HasTypes a where
types :: Traversal' a Type'
freeTvs :: a -> HashSet PsName
boundTvs :: a -> HashSet PsName
subst :: Name -> Type' -> a -> a
freeTvs = foldMapOf types $ cata \case
VarTF n -> S.singleton n
t -> fold t
boundTvs = const mempty
subst k v = types %~ cata \case
VarTF n | k == n -> v
t -> embed t
instance HasTypes Constraint where
types k (Equality s t) = Equality <$> types k s <*> types k t
types k (ImplicitInstance m s t) =
ImplicitInstance <$> types k m <*> types k s <*> types k t
types k (ExplicitInstance s t) =
ExplicitInstance <$> types k s <*> types k t
instance (Hashable a, HasTypes a) => HasTypes (HashSet a) where
types k = traverseHashSetBad (types k)
instance HasTypes Type' where
types = id
freeTvs = cata \case
VarTF n -> S.singleton n
ForallTF x t -> S.delete x t
t -> fold t
boundTvs = cata \case
ForallTF x t -> S.insert x t
t -> fold t
subst k v = para \case
VarTF n | k == n -> v
ForallTF x (pre,post)
| k == x -> ForallT x pre
t -> embed $ snd <$> t
-- illegal traversal
traverseHashSetBad :: (Hashable a, Hashable b)
=> Traversal (HashSet a) (HashSet b) a b
traverseHashSetBad k s = fmap S.fromList $ traverse k (S.toList s)
--------------------------------------------------------------------------------
makePrisms ''Judgement
makeLenses ''Judgement
makePrisms ''Constraint
makePrisms ''TypeError

30
src/Rlp/HindleyMilner/Visual.hs
View File

@@ -1,30 +0,0 @@
{-# LANGUAGE LexicalNegation #-}
module Rlp.HindleyMilner.Visual
(
)
where
--------------------------------------------------------------------------------
import Control.Monad
import System.IO
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Pretty hiding (annotate)
import Data.String (IsString(..))
import Data.Foldable
import Misc.CofreeF
import Control.Exception
import Data.Functor.Foldable
import Data.Aeson
import Core.Syntax as Core
import Rlp.AltSyntax as Rlp
import Rlp.HindleyMilner
import Prelude hiding ((**))
--------------------------------------------------------------------------------
type AnnExpr = Cofree (RlpExprF PsName)

382
src/Rlp/Lex.x
View File

@@ -1,382 +0,0 @@
{
{-# LANGUAGE ViewPatterns, LambdaCase #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Rlp.Lex
( P(..)
, RlpToken(..)
, Located(..)
, lexToken
, lexStream
, lexStream'
, lexDebug
, lexCont
, popLexState
, programInitState
, runP'
, popLayout
)
where
import Codec.Binary.UTF8.String (encodeChar)
import Control.Monad
import Control.Monad.Errorful
import Core.Syntax (Name)
import Data.Functor.Identity
import Data.Char (digitToInt)
import Data.Monoid (First)
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word
import Data.Default
import Control.Lens
import Compiler.Types
import Debug.Trace
import Rlp.Parse.Types
}
$whitechar = [ \t\n\r\f\v]
$nl = [\n\r]
$white_no_nl = $white # $nl
$lower = [a-z \_]
$upper = [A-Z]
$alpha = [$lower $upper]
$digit = 0-9
$special = [\(\)\,\;\[\]\{\}]
$namechar = [$alpha $digit \' \#]
$asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
@decimal = $digit+
@varname = $lower $namechar*
@conname = $upper $namechar*
@consym = \: $asciisym*
@varsym = $asciisym+
@reservedname =
case|data|do|import|in|let|letrec|module|of|where
|infixr|infixl|infix|forall
@reservedop =
"=" | \\ | "->" | "|" | ":"
rlp :-
-- everywhere: skip whitespace
$white_no_nl+ ;
-- everywhere: skip comments
-- TODO: don't treat operators like (-->) as comments
"--".* ;
-- we are indentation-sensitive! do not skip NLs!. upon encountering a newline,
-- we check indentation and potentially insert extra tokens. search this file
-- for the definition of `doBol`
<0> \n { beginPush bol }
<layout>
{
}
-- layout keywords
<0>
{
"let" { constToken TokenLet `thenBeginPush` layout_let }
"letrec" { constToken TokenLetrec `thenBeginPush` layout_let }
"of" { constToken TokenOf `thenBeginPush` layout_of }
}
-- scan various identifiers and reserved words. order is important here!
<0>
{
@reservedname { tokenWith lexReservedName }
@conname { tokenWith TokenConName }
@varname { tokenWith TokenVarName }
@reservedop { tokenWith lexReservedOp }
@consym { tokenWith TokenConSym }
@varsym { tokenWith TokenVarSym }
}
-- literals -- currently this is just unsigned integer literals
<0>
{
@decimal { tokenWith (TokenLitInt . readInt) }
}
-- control characters
<0>
{
"(" { constToken TokenLParen }
")" { constToken TokenRParen }
"{" { explicitLBrace }
"}" { explicitRBrace }
";" { constToken TokenSemicolon }
}
-- consume all whitespace leaving us at the beginning of the next non-empty
-- line. we then compare the indentation of that line to the enclosing layout
-- context and proceed accordingly
<bol>
{
$whitechar ;
\n ;
() { doBol }
}
<layout_top>
{
\n ;
"{" { explicitLBrace `thenDo` popLexState }
}
<layout, layout_let, layout_of>
{
\n { beginPush bol }
"{" { explicitLBrace `thenDo` popLexState }
}
<layout_let>
{
"in" { constToken TokenIn `thenDo` (popLexState *> popLayout) }
}
<layout, layout_top, layout_let, layout_of>
{
() { doLayout }
}
{
lexReservedName :: Text -> RlpToken
lexReservedName = \case
"data" -> TokenData
"case" -> TokenCase
"of" -> TokenOf
"let" -> TokenLet
"letrec" -> TokenLetrec
"in" -> TokenIn
"infix" -> TokenInfix
"infixl" -> TokenInfixL
"infixr" -> TokenInfixR
"forall" -> TokenForall
s -> error (show s)
lexReservedOp :: Text -> RlpToken
lexReservedOp = \case
"=" -> TokenEquals
":" -> TokenHasType
"|" -> TokenPipe
"->" -> TokenArrow
"\\" -> TokenLambda
s -> error (show s)
-- | @andBegin@, with the subtle difference that the start code is set
-- /after/ the action
thenBegin :: LexerAction a -> Int -> LexerAction a
thenBegin act c inp l = do
a <- act inp l
psLexState . _head .= c
pure a
thenBeginPush :: LexerAction a -> Int -> LexerAction a
thenBeginPush act c inp l = do
a <- act inp l
pushLexState c
pure a
andBegin :: LexerAction a -> Int -> LexerAction a
andBegin act c inp l = do
psLexState . _head .= c
act inp l
beginPush :: Int -> LexerAction (Located RlpToken)
beginPush n _ _ = pushLexState n >> lexToken
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte inp = case inp ^. aiBytes of
[] -> do
(c,t) <- T.uncons (inp ^. aiSource)
let (b:bs) = encodeChar c
-- tail the source
inp' = inp & aiSource .~ t
-- record the excess bytes for successive calls
& aiBytes .~ bs
-- report the previous char
& aiPrevChar .~ c
-- update the position
& aiPos %~ \ (ln,col,a) ->
if c == '\n'
then (ln+1, 1, a+1)
else (ln, col+1, a+1)
pure (b, inp')
_ -> Just (head bs, inp')
where
(bs, inp') = inp & aiBytes <<%~ drop 1
getInput :: P AlexInput
getInput = use psInput
getLexState :: P Int
getLexState = use (psLexState . singular _head)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar = view aiPrevChar
pushLexState :: Int -> P ()
pushLexState n = psLexState %= (n:)
readInt :: Text -> Int
readInt = T.foldl f 0 where
f n c = 10*n + digitToInt c
constToken :: RlpToken -> LexerAction (Located RlpToken)
constToken t inp l = do
pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos l) t)
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
tokenWith tf inp l = do
pos <- getPos
let t = tf (T.take l $ inp ^. aiSource)
pure (Located (spanFromPos pos l) t)
getPos :: P Position
getPos = use (psInput . aiPos)
alexEOF :: P (Located RlpToken)
alexEOF = do
inp <- getInput
pos <- getPos
pure (Located (spanFromPos pos 0) TokenEOF)
runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
runP' p s = runP p st where
st = initParseState [layout_top,0] s
lexToken :: P (Located RlpToken)
lexToken = do
inp <- getInput
c <- getLexState
st <- use id
-- traceM $ "st: " <> show st
case alexScan inp c of
AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
AlexSkip inp' l -> do
psInput .= inp'
lexToken
AlexToken inp' l act -> do
psInput .= inp'
act inp l
AlexError inp' -> addFatalHere 1 RlpParErrLexical
lexCont :: (Located RlpToken -> P a) -> P a
lexCont = (lexToken >>=)
lexStream :: P [RlpToken]
lexStream = fmap extract <$> lexStream'
lexStream' :: P [Located RlpToken]
lexStream' = lexToken >>= \case
t@(Located _ TokenEOF) -> pure [t]
t -> (t:) <$> lexStream'
lexDebug :: (Located RlpToken -> P a) -> P a
lexDebug k = do
t <- lexToken
traceM $ "token: " <> show t
k t
lexTest :: Text -> Maybe [RlpToken]
lexTest s = runP' lexStream s ^. _3
indentLevel :: P Int
indentLevel = do
pos <- use (psInput . aiPos)
pure (pos ^. _2)
insertToken :: RlpToken -> P (Located RlpToken)
insertToken t = do
pos <- use (psInput . aiPos)
pure (Located (spanFromPos pos 0) t)
popLayout :: P Layout
popLayout = do
-- traceM "pop layout"
ctx <- preuse (psLayoutStack . _head)
psLayoutStack %= (drop 1)
case ctx of
Just l -> pure l
Nothing -> error "popLayout: layout stack empty! this is a bug."
pushLayout :: Layout -> P ()
pushLayout l = do
-- traceM "push layout"
psLayoutStack %= (l:)
popLexState :: P ()
popLexState = do
psLexState %= tail
insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken)
insertSemicolon = {- traceM "inserting semi" >> -} insertToken TokenSemicolonV
insertLBrace = {- traceM "inserting lbrace" >> -} insertToken TokenLBraceV
insertRBrace = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV
cmpLayout :: P Ordering
cmpLayout = do
i <- indentLevel
-- traceM $ "i: " <> show i
ctx <- preuse (psLayoutStack . _head)
case ctx of
Just (Implicit n) -> pure (i `compare` n)
_ -> pure GT
doBol :: LexerAction (Located RlpToken)
doBol inp l = do
off <- cmpLayout
-- important that we pop the lex state lest we find our lexer diverging
case off of
-- the line is aligned with the previous. it therefore belongs to the
-- same list
EQ -> popLexState *> insertSemicolon
-- the line is indented further than the previous, so we assume it is a
-- line continuation. ignore it and move on!
GT -> popLexState *> lexToken
-- the line is indented less than the previous, pop the layout stack and
-- insert a closing brace. make VERY good note of the fact that we do not
-- pop the lex state! this means doBol is called until indentation is EQ
-- GT. so if multiple layouts are closed at once, this catches that.
LT -> popLayout >> insertRBrace
thenDo :: LexerAction a -> P b -> LexerAction a
thenDo act p inp l = act inp l <* p
explicitLBrace :: LexerAction (Located RlpToken)
explicitLBrace inp l = do
pushLayout Explicit
constToken TokenLBrace inp l
explicitRBrace :: LexerAction (Located RlpToken)
explicitRBrace inp l = do
popLayout
constToken TokenRBrace inp l
doLayout :: LexerAction (Located RlpToken)
doLayout _ _ = do
i <- indentLevel
-- traceM $ "doLayout: i: " <> show i
pushLayout (Implicit i)
popLexState
insertLBrace
programInitState :: Text -> ParseState
programInitState = initParseState [layout_top,0]
}

334
src/Rlp/Parse.y
View File

@@ -1,334 +0,0 @@
{
{-# LANGUAGE LambdaCase, ViewPatterns #-}
module Rlp.Parse
( parseRlpProg
, parseRlpProgR
, parseRlpExpr
, parseRlpExprR
, runP'
)
where
import Compiler.RlpcError
import Compiler.RLPC
import Control.Comonad.Cofree
import Rlp.Lex
import Rlp.Syntax
import Rlp.Parse.Types
import Rlp.Parse.Associate
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
import Data.List.Extra
import Data.Fix
import Data.Functor.Const
import Data.Functor.Apply
import Data.Functor.Bind
import Control.Comonad
import Data.Functor
import Data.Semigroup.Traversable
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void
import Compiler.Types
}
%name parseRlpProg StandaloneProgram
%name parseRlpExpr StandaloneExpr
%monad { P }
%lexer { lexCont } { Located _ TokenEOF }
%error { parseError }
%errorhandlertype explist
%tokentype { Located RlpToken }
%token
varname { Located _ (TokenVarName _) }
conname { Located _ (TokenConName _) }
consym { Located _ (TokenConSym _) }
varsym { Located _ (TokenVarSym _) }
data { Located _ TokenData }
case { Located _ TokenCase }
of { Located _ TokenOf }
litint { Located _ (TokenLitInt _) }
'=' { Located _ TokenEquals }
'|' { Located _ TokenPipe }
'::' { Located _ TokenHasType }
';' { Located _ TokenSemicolon }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'->' { Located _ TokenArrow }
vsemi { Located _ TokenSemicolonV }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
vlbrace { Located _ TokenLBraceV }
vrbrace { Located _ TokenRBraceV }
infixl { Located _ TokenInfixL }
infixr { Located _ TokenInfixR }
infix { Located _ TokenInfix }
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
in { Located _ TokenIn }
%nonassoc '='
%right '->'
%right in
%%
StandaloneProgram :: { Program RlpcPs SrcSpan }
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
: VL Expr VR { $2 }
VL :: { () }
VL : vlbrace { () }
VR :: { () }
VR : vrbrace { () }
| error {% void popLayout }
VS :: { () }
VS : ';' { () }
| vsemi { () }
Decl :: { Decl RlpcPs SrcSpan }
: FunDecl { $1 }
| TySigDecl { $1 }
| DataDecl { $1 }
| InfixDecl { $1 }
TySigDecl :: { Decl RlpcPs SrcSpan }
: Var '::' Type { TySigD [$1] $3 }
InfixDecl :: { Decl RlpcPs SrcSpan }
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
InfixWord :: { Assoc }
: infixl { InfixL }
| infixr { InfixR }
| infix { Infix }
DataDecl :: { Decl RlpcPs SrcSpan }
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
TyParams :: { [PsName] }
: {- epsilon -} { [] }
| TyParams varname { $1 `snoc` extractName $2 }
DataCons :: { [ConAlt RlpcPs] }
: DataCons '|' DataCon { $1 `snoc` $3 }
| DataCon { [$1] }
DataCon :: { ConAlt RlpcPs }
: Con Type1s { ConAlt $1 $2 }
Type1s :: { [Ty RlpcPs] }
: {- epsilon -} { [] }
| Type1s Type1 { $1 `snoc` $2 }
Type1 :: { Ty RlpcPs }
: '(' Type ')' { $2 }
| conname { ConT (extractName $1) }
| varname { VarT (extractName $1) }
Type :: { Ty RlpcPs }
: Type '->' Type { FunT $1 $3 }
| TypeApp { $1 }
TypeApp :: { Ty RlpcPs }
: Type1 { $1 }
| TypeApp Type1 { AppT $1 $2 }
FunDecl :: { Decl RlpcPs SrcSpan }
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
Params :: { [Pat RlpcPs] }
Params : {- epsilon -} { [] }
| Params Pat1 { $1 `snoc` $2 }
Pat :: { Pat RlpcPs }
: Con Pat1s { ConP $1 $2 }
| Pat1 { $1 }
Pat1s :: { [Pat RlpcPs] }
: Pat1s Pat1 { $1 `snoc` $2 }
| Pat1 { [$1] }
Pat1 :: { Pat RlpcPs }
: Con { ConP $1 [] }
| Var { VarP $1 }
| Lit { LitP $1 }
| '(' Pat ')' { $2 }
Expr :: { Expr' RlpcPs SrcSpan }
-- infixities delayed till next release :(
-- : Expr1 InfixOp Expr { undefined }
: AppExpr { $1 }
| TempInfixExpr { $1 }
| LetExpr { $1 }
| CaseExpr { $1 }
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
AppExpr :: { Expr' RlpcPs SrcSpan }
: Expr1 { $1 }
| AppExpr Expr1 { comb2 AppEF $1 $2 }
LetExpr :: { Expr' RlpcPs SrcSpan }
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
CaseExpr :: { Expr' RlpcPs SrcSpan }
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
-- TODO: where-binds
Alt :: { Alt' RlpcPs SrcSpan }
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
-- layout0(p : β) :: [β]
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
| VL layout_list0(VS,p) VR { $2 }
-- layout_list0(sep : α, p : β) :: [β]
layout_list0(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
| {- epsilon -} { [] }
-- layout1(p : β) :: [β]
layout1(p) : '{' layout_list1(';',p) '}' { $2 }
| VL layout_list1(VS,p) VR { $2 }
-- layout_list1(sep : α, p : β) :: [β]
layout_list1(sep,p) : p { [$1] }
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
Binding :: { Binding' RlpcPs SrcSpan }
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
Expr1 :: { Expr' RlpcPs SrcSpan }
: '(' Expr ')' { $2 }
| Lit { nolo' $ LitEF $1 }
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
InfixOp :: { PsName }
: consym { extractName $1 }
| varsym { extractName $1 }
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
Lit :: { Lit RlpcPs }
: litint { $1 ^. to extract
. singular _TokenLitInt
. to IntL }
Var :: { PsName }
Var : varname { $1 <&> view (singular _TokenVarName) }
| varsym { $1 <&> view (singular _TokenVarSym) }
Con :: { PsName }
: conname { $1 <&> view (singular _TokenConName) }
{
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
parseRlpProgR s = do
a <- liftErrorful $ pToErrorful parseRlpProg st
addDebugMsg @_ @String "dump-parsed" $ show a
pure a
where
st = programInitState s
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
where
st = programInitState s
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
mkInfixD a p ln@(Located ss n) = do
let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n
opl <~ (use opl >>= \case
Just o -> addWoundHere l e >> pure (Just o) where
e = RlpParErrDuplicateInfixD n
l = T.length n
Nothing -> pure (Just (a,p))
)
pos <- use (psInput . aiPos)
pure $ InfixD a p ln
{--
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
where
st = programInitState s
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
parseRlpProgR s = do
a <- liftErrorful $ pToErrorful parseRlpProg st
addDebugMsg @_ @String "dump-parsed" $ show a
pure a
where
st = programInitState s
mkPsName :: Located RlpToken -> Located PsName
mkPsName = fmap extractName
extractName :: RlpToken -> PsName
extractName = \case
TokenVarName n -> n
TokenConName n -> n
TokenConSym n -> n
TokenVarSym n -> n
_ -> error "mkPsName: not an identifier"
extractInt :: RlpToken -> Int
extractInt (TokenLitInt n) = n
extractInt _ = error "extractInt: ugh"
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
mkProgram ds = do
pt <- use psOpTable
pure $ Program (associate pt <$> ds)
intOfToken :: Located RlpToken -> Int
intOfToken (Located _ (TokenLitInt n)) = n
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
tempInfixExprErr (Located a _) (Located b _) =
addFatal $ errorMsg (a <> b) $ RlpParErrOther
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
, "In the mean time, don't mix any infix operators."
]
--}
_litint :: Getter (Located RlpToken) Int
_litint = to extract
. singular _TokenLitInt
tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
tempInfixExprErr (a :< _) (b :< _) =
addFatal $ errorMsg (a <> b) $ RlpParErrOther
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
, "In the mean time, don't mix any infix operators."
]
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
mkProgram ds = do
pt <- use psOpTable
pure $ Program (associate pt <$> ds)
extractName :: Located RlpToken -> PsName
extractName (Located ss (TokenVarSym n)) = Located ss n
extractName (Located ss (TokenVarName n)) = Located ss n
extractName (Located ss (TokenConName n)) = Located ss n
extractName (Located ss (TokenConSym n)) = Located ss n
parseError :: (Located RlpToken, [String]) -> P a
parseError ((Located ss t), exp) = addFatal $
errorMsg ss (RlpParErrUnexpectedToken t exp)
}

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

@@ -1,37 +0,0 @@
module Rlp.Parse.Associate
{-# WARNING "unimplemented" #-}
( associate
)
where
--------------------------------------------------------------------------------
import Data.HashMap.Strict qualified as H
import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Data.Functor.Const
import Data.Functor
import Data.Text qualified as T
import Text.Printf
import Control.Lens
import Rlp.Parse.Types
import Rlp.Syntax
--------------------------------------------------------------------------------
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
associate _ p = p
{-# WARNING associate "unimplemented" #-}
examplePrecTable :: OpTable
examplePrecTable = H.fromList
[ ("+", (InfixL,6))
, ("*", (InfixL,7))
, ("^", (InfixR,8))
, (".", (InfixR,7))
, ("~", (Infix, 9))
, ("=", (Infix, 4))
, ("&&", (Infix, 3))
, ("||", (Infix, 2))
, ("$", (InfixR,0))
, ("&", (InfixL,0))
]

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

@@ -1,297 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
module Rlp.Parse.Types
(
-- * Trees That Grow
RlpcPs
-- * Parser monad and state
, P(..), ParseState(..), Layout(..), OpTable, OpInfo
, initParseState, initAlexInput
, pToErrorful
-- ** Lenses
, psLayoutStack, psLexState, psInput, psOpTable
-- * Other parser types
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
, Located(..), PsName
, srcSpanLen
-- ** Lenses
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
-- * Error handling
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
, addFatal, addWound, addFatalHere, addWoundHere
)
where
--------------------------------------------------------------------------------
import Core.Syntax (Name)
import Text.Show.Deriving
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Errorful
import Control.Comonad (extract)
import Compiler.RlpcError
import Language.Haskell.TH.Syntax (Lift)
import Data.Text (Text)
import Data.Maybe
import Data.Fix
import Data.Functor.Foldable
import Data.Functor.Const
import Data.Functor.Classes
import Data.HashMap.Strict qualified as H
import Data.Void
import Data.Word (Word8)
import Data.Text qualified as T
import Control.Lens hiding ((<<~))
import Rlp.Syntax
import Compiler.Types
--------------------------------------------------------------------------------
-- | Phantom type identifying rlpc's parser phase
data RlpcPs
type instance NameP RlpcPs = PsName
type PsName = Located Text
--------------------------------------------------------------------------------
spanFromPos :: Position -> Int -> SrcSpan
spanFromPos (l,c,a) s = SrcSpan l c a s
{-# INLINE spanFromPos #-}
type LexerAction a = AlexInput -> Int -> P a
data AlexInput = AlexInput
{ _aiPrevChar :: Char
, _aiSource :: Text
, _aiBytes :: [Word8]
, _aiPos :: Position
}
deriving Show
type Position =
( Int -- ^ line
, Int -- ^ column
, Int -- ^ Absolutely
)
posLine :: Lens' Position Int
posLine = _1
posColumn :: Lens' Position Int
posColumn = _2
posAbsolute :: Lens' Position Int
posAbsolute = _3
data RlpToken
-- literals
= TokenLitInt Int
-- identifiers
| TokenVarName Text
| TokenConName Text
| TokenVarSym Text
| TokenConSym Text
-- reserved words
| TokenData
| TokenCase
| TokenOf
| TokenLet
| TokenLetrec
| TokenIn
| TokenInfixL
| TokenInfixR
| TokenInfix
| TokenForall
-- reserved ops
| TokenArrow
| TokenPipe
| TokenHasType
| TokenLambda
| TokenEquals
-- control symbols
| TokenSemicolon
| TokenLBrace
| TokenRBrace
| TokenLParen
| TokenRParen
-- 'virtual' control symbols, inserted by the lexer without any correlation
-- to a specific part of the input
| TokenSemicolonV
| TokenLBraceV
| TokenRBraceV
| TokenEOF
deriving (Show)
_TokenLitInt :: Prism' RlpToken Int
_TokenLitInt = prism TokenLitInt $ \case
TokenLitInt n -> Right n
x -> Left x
_TokenVarName :: Prism' RlpToken Text
_TokenVarName = prism TokenVarName $ \case
TokenVarName n -> Right n
x -> Left x
_TokenVarSym :: Prism' RlpToken Text
_TokenVarSym = prism TokenVarSym $ \case
TokenVarSym n -> Right n
x -> Left x
_TokenConName :: Prism' RlpToken Text
_TokenConName = prism TokenConName $ \case
TokenConName n -> Right n
x -> Left x
_TokenConSym :: Prism' RlpToken Text
_TokenConSym = prism TokenConSym $ \case
TokenConSym n -> Right n
x -> Left x
newtype P a = P {
runP :: ParseState
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
}
deriving (Functor)
pToErrorful :: (Applicative m)
=> P a -> ParseState -> ErrorfulT (MsgEnvelope RlpParseError) m a
pToErrorful p st = ErrorfulT $ pure (ma,es) where
(_,es,ma) = runP p st
instance Applicative P where
pure a = P $ \st -> (st, [], pure a)
liftA2 = liftM2
instance Monad P where
p >>= k = P $ \st ->
let (st',es,ma) = runP p st
in case ma of
Just a -> runP (k a) st'
& _2 %~ (es<>)
Nothing -> (st',es,Nothing)
{-# INLINE (>>=) #-}
instance MonadState ParseState P where
state f = P $ \st ->
let (a,st') = f st
in (st', [], Just a)
instance MonadErrorful (MsgEnvelope RlpParseError) P where
addWound e = P $ \st -> (st, [e], Just ())
addFatal e = P $ \st -> (st, [e], Nothing)
data ParseState = ParseState
{ _psLayoutStack :: [Layout]
, _psLexState :: [Int]
, _psInput :: AlexInput
, _psOpTable :: OpTable
}
deriving Show
data Layout = Explicit
| Implicit Int
deriving (Show, Eq)
type OpTable = H.HashMap Name OpInfo
type OpInfo = (Assoc, Int)
data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
| RlpParErrDuplicateInfixD Name
| RlpParErrLexical
| RlpParErrUnexpectedToken RlpToken [String]
| RlpParErrOther [Text]
deriving (Show)
instance IsRlpcError RlpParseError where
liftRlpcError = \case
RlpParErrOutOfBoundsPrecedence n ->
Text [ "Illegal precedence in infixity declaration"
, "rl' currently only allows precedences between 0 and 9."
]
RlpParErrDuplicateInfixD s ->
Text [ "Conflicting infixity declarations for operator "
<> tshow s
]
RlpParErrLexical ->
Text [ "Unknown lexical error :(" ]
RlpParErrUnexpectedToken t exp ->
Text [ "Unexpected token " <> tshow t
, "Expected: " <> tshow exp
]
RlpParErrOther ts ->
Text ts
where
tshow :: (Show a) => a -> T.Text
tshow = T.pack . show
----------------------------------------------------------------------------------
makeLenses ''AlexInput
makeLenses ''ParseState
addWoundHere :: Int -> RlpParseError -> P ()
addWoundHere l e = P $ \st ->
let e' = MsgEnvelope
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError
}
in (st, [e'], Just ())
addFatalHere :: Int -> RlpParseError -> P a
addFatalHere l e = P $ \st ->
let e' = MsgEnvelope
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError
}
in (st, [e'], Nothing)
initParseState :: [Int] -> Text -> ParseState
initParseState ls s = ParseState
{ _psLayoutStack = []
-- IMPORTANT: the initial state is `bol` to begin the top-level layout,
-- which then returns to state 0 which continues the normal lexing process.
, _psLexState = ls
, _psInput = initAlexInput s
, _psOpTable = mempty
}
initAlexInput :: Text -> AlexInput
initAlexInput s = AlexInput
{ _aiPrevChar = '\0'
, _aiSource = s
, _aiBytes = []
, _aiPos = (1,1,0)
}
--------------------------------------------------------------------------------
-- deriving instance Lift (Program RlpcPs)
-- deriving instance Lift (Decl RlpcPs)
-- deriving instance Lift (Pat RlpcPs)
-- deriving instance Lift (Lit RlpcPs)
-- deriving instance Lift (Expr RlpcPs)
-- deriving instance Lift (Binding RlpcPs)
-- deriving instance Lift (Ty RlpcPs)
-- deriving instance Lift (Alt RlpcPs)
-- deriving instance Lift (ConAlt RlpcPs)

10
src/Rlp/Syntax.hs
View File

@@ -1,10 +0,0 @@
module Rlp.Syntax
( module Rlp.Syntax.Backstage
, module Rlp.Syntax.Types
)
where
--------------------------------------------------------------------------------
import Rlp.Syntax.Backstage
import Rlp.Syntax.Types
--------------------------------------------------------------------------------

35
src/Rlp/Syntax/Backstage.hs
View File

@@ -1,35 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Rlp.Syntax.Backstage
( strip
)
where
--------------------------------------------------------------------------------
import Data.Fix hiding (cata)
import Data.Functor.Classes
import Data.Functor.Foldable
import Rlp.Syntax.Types
import Text.Show.Deriving
import Language.Haskell.TH.Syntax (Lift)
--------------------------------------------------------------------------------
-- oprhan instances because TH
instance (Show (NameP p)) => Show1 (Alt p) where
liftShowsPrec = $(makeLiftShowsPrec ''Alt)
instance (Show (NameP p)) => Show1 (Binding p) where
liftShowsPrec = $(makeLiftShowsPrec ''Binding)
instance (Show (NameP p)) => Show1 (ExprF p) where
liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
deriving instance (Show (NameP p), Show a) => Show (Decl p a)
deriving instance (Show (NameP p), Show a) => Show (Program p a)
strip :: Functor f => Cofree f a -> Fix f
strip (_ :< as) = Fix $ strip <$> as

145
src/Rlp/Syntax/Types.hs
View File

@@ -1,145 +0,0 @@
-- recursion-schemes
{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax.Types
(
NameP
, SimpleP
, Assoc(..)
, ConAlt(..)
, Alt(..), Alt'
, Ty(..)
, Binding(..), Binding'
, Expr', ExprF(..)
, Rec(..)
, Lit(..)
, Pat(..)
, Decl(..), Decl'
, Program(..)
, Where
-- * Re-exports
, Cofree(..)
, Trans.Cofree.CofreeF
, SrcSpan(..)
, programDecls
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Data.Text qualified as T
import Data.String (IsString(..))
import Data.Functor.Classes
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Fix
import Data.Kind (Type)
import GHC.Generics
import Language.Haskell.TH.Syntax (Lift)
import Control.Lens hiding ((:<))
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
import Control.Comonad.Cofree
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Compiler.Types (SrcSpan(..), Located(..))
import Core.Syntax qualified as Core
import Core (Rec(..), HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
data SimpleP
type instance NameP SimpleP = String
type family NameP p
data ExprF p a = LetEF Rec [Binding p a] a
| VarEF (NameP p)
| LamEF [Pat p] a
| CaseEF a [Alt p a]
| IfEF a a a
| AppEF a a
| LitEF (Lit p)
| ParEF a
| InfixEF (NameP p) a a
deriving (Functor, Foldable, Traversable)
data ConAlt p = ConAlt (NameP p) [Ty p]
deriving instance (Lift (NameP p)) => Lift (ConAlt p)
deriving instance (Show (NameP p)) => Show (ConAlt p)
data Ty p = ConT (NameP p)
| VarT (NameP p)
| FunT (Ty p) (Ty p)
| AppT (Ty p) (Ty p)
deriving instance (Show (NameP p)) => Show (Ty p)
deriving instance (Lift (NameP p)) => Lift (Ty p)
data Pat p = VarP (NameP p)
| LitP (Lit p)
| ConP (NameP p) [Pat p]
deriving instance (Lift (NameP p)) => Lift (Pat p)
deriving instance (Show (NameP p)) => Show (Pat p)
data Lit p = IntL Int
deriving Show
deriving instance (Lift (NameP p)) => Lift (Lit p)
data Assoc = InfixL | InfixR | Infix
deriving (Lift, Show)
deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
data Binding p a = PatB (Pat p) (ExprF p a)
deriving (Functor, Foldable, Traversable)
deriving instance (Lift (NameP p), Lift a) => Lift (Binding p a)
deriving instance (Show (NameP p), Show a) => Show (Binding p a)
type Binding' p a = Binding p (Cofree (ExprF p) a)
type Where p a = [Binding p a]
data Alt p a = AltA (Pat p) (ExprF p a) (Maybe (Where p a))
deriving (Functor, Foldable, Traversable)
deriving instance (Show (NameP p), Show a) => Show (Alt p a)
deriving instance (Lift (NameP p), Lift a) => Lift (Alt p a)
type Expr p = Fix (ExprF p)
type Alt' p a = Alt p (Cofree (ExprF p) a)
--------------------------------------------------------------------------------
data Program p a = Program
{ _programDecls :: [Decl p a]
}
data Decl p a = FunD (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a))
| TySigD [NameP p] (Ty p)
| DataD (NameP p) [NameP p] [ConAlt p]
| InfixD Assoc Int (NameP p)
type Decl' p a = Decl p (Cofree (ExprF p) a)
type Expr' p = Cofree (ExprF p)
makeLenses ''Program
loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
loccof = iso sa bt where
sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
sa (ss :< as) = Located ss as
bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
bt (Located ss as) = ss :< as

36
src/Rlp/TH.hs
View File

@@ -1,36 +0,0 @@
module Rlp.TH
( rlpProg
, rlpExpr
)
where
--------------------------------------------------------------------------------
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Text (Text)
import Data.Text qualified as T
import Control.Monad.IO.Class
import Control.Monad
import Compiler.RLPC
import Rlp.AltParse
--------------------------------------------------------------------------------
rlpProg :: QuasiQuoter
rlpProg = mkqq parseRlpProgR
rlpExpr :: QuasiQuoter
rlpExpr = mkqq parseRlpExprR
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
mkq parse = evalAndParse >=> lift where
evalAndParse = liftIO . evalRLPCIO def . parse . T.pack
mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
mkqq p = QuasiQuoter
{ quoteExp = mkq p
, quotePat = error "rlp quasiquotes may only be used in expressions"
, quoteType = error "rlp quasiquotes may only be used in expressions"
, quoteDec = error "rlp quasiquotes may only be used in expressions"
}

124
src/Rlp2Core.hs
View File

@@ -1,124 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveTraversable #-}
module Rlp2Core
( desugarRlpProgR
, desugarRlpProg
, desugarRlpExpr
)
where
--------------------------------------------------------------------------------
import Control.Monad
import Control.Monad.Writer.CPS
import Control.Monad.Utils
import Control.Arrow
import Control.Applicative
import Control.Lens hiding ((:<))
import Compiler.RLPC
import Data.List (mapAccumL, partition)
import Data.Text (Text)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
import Data.Monoid (Endo(..))
import Data.Either (partitionEithers)
import Data.Foldable
import Data.Maybe (fromJust, fromMaybe)
import Data.Function (on)
import GHC.Stack
import Debug.Trace
import Numeric
import Data.Fix hiding (cata, para, cataM)
import Data.Functor.Bind
import Data.Functor.Foldable
import Control.Comonad
import Effectful.State.Static.Local
import Effectful.Labeled
import Effectful
import Text.Show.Deriving
import Core.Syntax as Core
import Rlp.AltSyntax as Rlp
import Compiler.Types
import Data.Pretty
--------------------------------------------------------------------------------
type Tree a = Either Name (Name, Branch a)
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
-- is, a constructor with children that are either a normal binder (Left (Given)
-- name) or an indirection to another pattern (Right (Generated name) (Pattern))
data Branch a = Branch Name [Tree a]
deriving (Show, Functor, Foldable, Traversable)
-- | The actual rose tree.
-- @type Rose = 'Data.Fix.Fix' 'Branch'@
type Rose = Fix Branch
deriveShow1 ''Branch
--------------------------------------------------------------------------------
-- desugarRlpProgR :: forall m a. (Monad m)
-- => Rlp.Program PsName (TypedRlpExpr PsName)
-- -> RLPCT m (Core.Program Var)
-- desugarRlpProgR p = do
-- let p' = desugarRlpProg p
-- addDebugMsg "dump-desugared" $ show (out p')
-- pure p'
desugarRlpProgR = undefined
desugarRlpProg :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
desugarRlpProg = rlpProgToCore
desugarRlpExpr = undefined
type NameSupply = Labeled "NameSupply" (State [Name])
runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
where tshow = T.pack . show
-- the rl' program is desugared by desugaring each declaration as a separate
-- program, and taking the monoidal product of the lot :3
rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
rlpProgToCore = foldMapOf (programDecls . each) declToCore
declToCore :: Rlp.Decl PsName (TypedRlpExpr PsName) -> Core.Program Var
-- assume full eta-expansion for now
declToCore (FunD b [] e) = mempty & programScDefs .~ [ScDef b' [] undefined]
where
b' = MkVar b (typeToCore $ extract e)
e' = runPureEff . runNameSupply b . exprToCore $ e
typeToCore :: Rlp.Type PsName -> Core.Type
typeToCore (VarT n) = TyVar n
exprToCore :: (NameSupply :> es)
=> TypedRlpExpr PsName
-> Eff es (Cofree (Core.ExprF Var) Core.Type)
exprToCore = undefined
annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
-- fixed points:
annotateVar _ (VarF n) = VarF n
annotateVar _ (ConF t a) = ConF t a
annotateVar _ (AppF f x) = AppF f x
annotateVar _ (LitF l) = LitF l
annotateVar _ (TypeF t) = TypeF t
rlpExprToCore :: (NameSupply :> es)
=> Rlp.ExprF PsName Core.Expr' -> Eff es Core.Expr'
-- assume all binders are simple variable patterns for now
rlpExprToCore (LetEF r bs e) = pure $ Let r bs' e
where
bs' = b2b <$> bs
b2b (VarB (VarP k) v) = Binding k v

3
src/TI.hs
View File

@@ -20,7 +20,8 @@ import System.IO (Handle, hPutStr)
import Text.Printf (printf, hPrintf) import Text.Printf (printf, hPrintf)
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy(..))
import Data.Monoid (Endo(..)) import Data.Monoid (Endo(..))
import Control.Lens import Lens.Micro
import Lens.Micro.TH
import Data.Pretty import Data.Pretty
import Data.Heap import Data.Heap
import Core.Examples import Core.Examples

1
tst/Arith.hs
View File

@@ -41,7 +41,6 @@ evalArith (a ::* b) = evalArith a * evalArith b
evalArith (a ::- b) = evalArith a - evalArith b evalArith (a ::- b) = evalArith a - evalArith b
instance Arbitrary ArithExpr where instance Arbitrary ArithExpr where
-- TODO: implement shrink
arbitrary = gen 4 arbitrary = gen 4
where where
gen :: Int -> Gen ArithExpr gen :: Int -> Gen ArithExpr

67
tst/Compiler/TypesSpec.hs
View File

@@ -1,67 +0,0 @@
{-# LANGUAGE ParallelListComp #-}
module Compiler.TypesSpec
( spec
)
where
--------------------------------------------------------------------------------
import Control.Lens.Combinators
import Data.Function ((&))
import Test.QuickCheck
import Test.Hspec
import Compiler.Types (SrcSpan(..), srcSpanAbs, srcSpanLen)
--------------------------------------------------------------------------------
spec :: Spec
spec = do
describe "SrcSpan" $ do
-- it "associates under closure"
-- prop_SrcSpan_mul_associative
it "commutes under closure"
prop_SrcSpan_mul_commutative
it "equals itself when squared"
prop_SrcSpan_mul_square_eq
prop_SrcSpan_mul_associative :: Property
prop_SrcSpan_mul_associative = property $ \a b c ->
-- very crudely approximate when overflow will occur; bail we think it
-- will
(([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen))
(< (maxBound @Int `div` 3)))
==> (a <> b) <> c === a <> (b <> c :: SrcSpan)
prop_SrcSpan_mul_commutative :: Property
prop_SrcSpan_mul_commutative = property $ \a b ->
a <> b === (b <> a :: SrcSpan)
prop_SrcSpan_mul_square_eq :: Property
prop_SrcSpan_mul_square_eq = property $ \a ->
a <> a === (a :: SrcSpan)
instance Arbitrary SrcSpan where
arbitrary = do
l <- chooseInt (1, maxBound)
c <- chooseInt (1, maxBound)
a <- chooseInt (0, maxBound)
`suchThat` (\n -> n >= pred l + pred c)
s <- chooseInt (0, maxBound)
pure $ SrcSpan l c a s
shrink (SrcSpan l c a s) =
[ SrcSpan l' c' a' s'
| (l',c',a',s') <- shrinkParts
, l' >= 1
, c' >= 1
, a' >= pred l' + pred c'
]
where
-- shfl as = unsafePerformIO (generate $ shuffle as)
shrinkParts =
[ (l',c',a',s')
| l' <- shrinkIntegral l
| c' <- shrinkIntegral c
| a' <- shrinkIntegral a
| s' <- shrinkIntegral s
]

24
tst/Core/HindleyMilnerSpec.hs
View File

@@ -38,25 +38,9 @@ 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" $ infer' :: Context' -> Expr' -> Either TypeError Type
let g = [ ("fix", ("a" :-> "a") :-> "a") infer' g e = fmap fst . runErrorful $ infer g e
, ("+#", TyInt :-> TyInt :-> TyInt) ]
e = [coreExpr|fix ((+#) 1)|]
in infer' g e `shouldBe` Right TyInt
it "should infer mutually recursively defined lists" $ check' :: Context' -> Type -> Expr' -> Either TypeError ()
let g = [ ("cons", TyInt :-> TyCon "IntList" :-> TyCon "IntList") ] check' g t e = fmap fst . runErrorful $ check g t e
e :: Expr'
e = [coreExpr|letrec { as = cons 1 bs; bs = cons 2 as } in as|]
in infer' g e `shouldBe` Right (TyCon "IntList")
infer' :: Context' -> Expr' -> Either [TypeError] Type
infer' g e = case runErrorful $ infer g e of
(Just t, _) -> Right t
(Nothing, es) -> Left es
check' :: Context' -> Type -> Expr' -> Either [TypeError] ()
check' g t e = case runErrorful $ check g t e of
(Just t, _) -> Right ()
(Nothing, es) -> Left es

40
tst/Core/ParseSpec.hs Normal file
View File

@@ -0,0 +1,40 @@
module Core.ParseSpec
( spec
)
where
----------------------------------------------------------------------------------
import CoreSyntax
import Core.Syntax
import Compiler.JustRun
import Compiler.RlpcError
import Control.Monad ((<=<))
import Data.Coerce
import Data.Text qualified as T
import Data.Functor.Classes (Eq1(..))
import Test.Hspec
import Test.QuickCheck
----------------------------------------------------------------------------------
spec :: Spec
spec = do
it "should be a right-inverse to the unparser \
\up to source code congruency" $
withMaxSuccess 20 $ property $
\p -> (unparse <=< parse) p ~== Right p
-- TODO: abitrary ASTs
-- it "should be a right-inverse to the unparser\
-- \up to source code congruency" $
-- property $ \p -> (parse <=< unparse) p == Right p
(~==) :: (Eq1 f) => f ProgramSrc -> f ProgramSrc -> Bool
(~==) = liftEq congruentSrc
infix 4 ~==
parse :: ProgramSrc -> Either RlpcError Program'
parse (ProgramSrc s) = justParseSrc (T.unpack s)
unparse :: Program' -> Either RlpcError ProgramSrc
unparse = Right . unparseCoreProg

303
tst/CoreSyntax.hs Normal file
View File

@@ -0,0 +1,303 @@
{-# LANGUAGE OverloadedStrings, LambdaCase, GeneralisedNewtypeDeriving #-}
module CoreSyntax
( ProgramSrc(..)
, congruentSrc
, unparseCoreProg
)
where
----------------------------------------------------------------------------------
import Core.Syntax
import Compiler.JustRun (justParseSrc)
import Control.Arrow ((>>>), (&&&))
import Control.Monad
import Data.List (intersperse)
import Data.Coerce (coerce)
import Data.Text (Text)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
import Test.QuickCheck
import Text.PrettyPrint hiding ((<>))
import Data.Functor ((<&>))
import Data.Function ((&), on)
import Data.String (IsString(..))
import Lens.Micro.Platform
import Lens.Micro.Platform.Internal (IsText(..))
----------------------------------------------------------------------------------
newtype ProgramSrc = ProgramSrc Text
deriving (Show, Read, Eq, Semigroup, Monoid, IsString)
instance Arbitrary ProgramSrc where
arbitrary = sized genProg where
genProg :: Int -> Gen ProgramSrc
genProg n = do
-- in generating a program, we create a random list of sc names and
-- assign them type signatures and definitions in random order.
ns <- replicateM n genName
-- generate a typesig and def for each name
ns & each %~ (genTySig &&& genScDef)
-- [(typesig, scdef)] -> [typesigs and scdefs]
& uncurry (++) . unzip
-- [Gen Text] -> Gen [Text]
& sequenceA
-- shuffle order of tysigs and scdefs
>>= shuffle
-- terminate each tysig and scdef with a semicolon with a blank
-- line for legibility
<&> intersperse ";\n\n"
-- mconcat into a single body of text
<&> mconcat
-- she's done! put a bow on her! :D
<&> ProgramSrc
genTySig :: Name -> Gen Text
genTySig n = conseq [pure n, ws, pure "::", ws, genTy]
genScDef :: Name -> Gen Text
genScDef n = conseq [pure n, ws, pure "=", ws, genExpr]
genExpr :: Gen Text
genExpr = gen 4 0 where
gen 0 _ = oneof
[ genVar
, genLit
]
gen n p = oneof
[ gen 0 p
, wrapParens <$> gen n' 0
, genApp n p
, genLet n p
-- , genLam n p
-- , genCase n p
]
where n' = next n
genVar = oneof
[ genName
, genCon
, wrapParens <$> genSymName
, wrapParens <$> genSymCon
]
genCase n p = conseq [ pure "case", ws1, gen n' 0, ws1, pure "of"
, pure "{", alts, pure "}"
]
<&> pprec 0 p
where
n' = next n
alts = chooseSize (1,6) (listOf1 alt)
<&> intersperse ";"
<&> mconcat
alt = conseq [ tag, ws, pure "->", ws1, gen n' 0 ]
tag = T.pack . show <$> chooseInt (0,maxBound)
genLit = T.pack . show <$> chooseInt (0,maxBound)
genApp n p = chooseSize (2,10) (listOf1 (gen n' 1))
<&> pprec 0 p . mconcat . intersperse " "
where
n' = next n
genLet n p = conseq [ letw, ws, pure "{", ws, binds
, ws, pure "}", ws, pure "in"
, ws1, gen n' 0
]
where
letw = arbitrary <&> \case
Rec -> "letrec"
NonRec -> "let"
binds = chooseSize (1,6) (listOf1 bind)
<&> intersperse ";"
<&> mconcat
bind = conseq [var, ws, pure "=", ws, gen n' 0]
var = oneof [genName, wrapParens <$> genSymName]
n' = next n
genLam n p = conseq [l, ws, bs, ws, pure "->", ws, gen n' 0]
<&> pprec 0 p
where
-- whitespace because reserved op shenanigans :3
l = elements [" \\ ", "λ"]
n' = next n
bs = chooseSize (0,6) (listOf1 genName)
<&> mconcat
next = (`div` 2)
genTy :: Gen Text
genTy = gen 4 where
gen 0 = genCon
gen n = oneof
[ gen 0
-- function types
, conseq [gen n', ws, pure "->", ws, gen n']
-- TODO: type applications (remember precedence lol)
]
where n' = n `div` 2
instance Arbitrary Rec where
arbitrary = elements [Rec,NonRec]
chooseSize :: (Int, Int) -> Gen a -> Gen a
chooseSize (a,b) g = do
n <- chooseInt (a,b)
resize n g
-- | @pprec q p s@ wraps @s@ with parens when @p <= q@
pprec :: (IsString a, Monoid a) => Int -> Int -> a -> a
pprec maxp p
| p <= maxp = id
| otherwise = wrapParens
wrapParens :: (IsString a, Monoid a) => a -> a
wrapParens t = "(" <> t <> ")"
conseq :: (Applicative f, Monoid m, Traversable t)
=> t (f m)
-> f m
conseq tfm = sequenceA tfm <&> the_cool_kid's_concat
-- me when `concat` is generalised in the container but specialised in the
-- value, and `mconcat` is specialised in the container but generalised in
-- the value. shoutout `foldMap id`
where the_cool_kid's_concat = foldMap id
genName :: Gen Name
genName = T.pack <$> liftA2 (:) small namechars where
small = elements ['a'..'z']
genCon :: Gen Name
genCon = T.pack <$> liftA2 (:) large namechars where
large = elements ['A'..'Z']
genSymName :: Gen Name
genSymName = T.pack <$> liftA2 (:) symbol symchars where
symbol = elements nameSymbols
genSymCon :: Gen Name
genSymCon = T.pack . (':' :) <$> symchars
namechars :: Gen String
namechars = liftArbitrary namechar where
namechar :: Gen Char
namechar = elements $ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] <> "'"
nameSymbols :: [Char]
nameSymbols = "!#$%&*+./<=>?@^|-~"
symchars :: Gen String
symchars = liftArbitrary symchar where
symchar = elements $ ':' : nameSymbols
txt :: (IsText t) => t -> Doc
txt t = t ^. unpacked & text
ws :: (IsString a) => Gen a
ws = elements [""," ", " "]
ws1 :: (IsString a) => Gen a
ws1 = elements [" ", " "]
----------------------------------------------------------------------------------
-- | Two bodies of source code are considered congruent iff the parser produces
-- identical ASTs for both.
congruentSrc :: ProgramSrc -> ProgramSrc -> Bool
congruentSrc = (==) `on` (justParseSrc . T.unpack . coerce)
----------------------------------------------------------------------------------
-- TODO: unparseCoreProg :: Program -> [CoreToken]
-- womp womp.
-- TODO: implement shrink
-- | @unparseCoreProg@ should be inverse to @parseCoreProg@ up to source code
-- congruency, newtype coercion and errors handling.
unparseCoreProg :: Program' -> ProgramSrc
unparseCoreProg p = unparseTypeSigs (p ^. programTypeSigs)
<> unparseScDefs (p ^. programScDefs)
unparseTypeSigs :: H.HashMap Name Type -> ProgramSrc
unparseTypeSigs = H.foldrWithKey f mempty
where f k v a = unparseTypeSig k v <> ";\n\n" <> a
unparseTypeSig :: Name -> Type -> ProgramSrc
unparseTypeSig n t = unparseName n <> " :: " <> unparseType t
unparseName :: Name -> ProgramSrc
unparseName n
| T.head n `elem` (':' : nameSymbols) = coerce $ wrapParens n
| otherwise = coerce n
unparseType :: Type -> ProgramSrc
unparseType = go 0 where
go :: Int -> Type -> ProgramSrc
-- (:->) is a special case of TyApp, but we want the infix syntax
go p (a :-> b) = a : assocFun b
<&> go 1
& coerce (T.intercalate " -> ")
& pprec 0 p
go p a@(TyApp f x) = assocApp a
<&> go 1
& coerce (T.intercalate " ")
& pprec 1 p
go _ TyFun = "(->)"
go _ (TyCon a) = unparseName a
go _ (TyVar a) = unparseName a
assocFun :: Type -> [Type]
assocFun (a :-> b) = a : assocFun b
assocFun x = [x]
assocApp :: Type -> [Type]
assocApp (TyApp f x) = assocApp f ++ [x]
assocApp x = [x]
unparseScDefs :: [ScDef'] -> ProgramSrc
unparseScDefs = foldr f mempty where
f sc a = unparseScDef sc <> ";\n\n" <> a
unparseScDef :: ScDef' -> ProgramSrc
unparseScDef (ScDef n as e) = (unparseName <$> (n:as)) <> ["=", unparseExpr e]
& coerce (T.intercalate " ")
unparseExpr :: Expr' -> ProgramSrc
unparseExpr = go 0 where
go :: Int -> Expr' -> ProgramSrc
go _ (Var n) = unparseName n
go _ (Con t a) = mconcat ["Pack{",srcShow t," ",srcShow a,"}"]
go _ (Lit l) = unparseLit l
go p a@(App _ _) = srci " " (go 1 <$> assocApp a)
& pprec 0 p
go p (Lam bs e) = "λ" <> srci " " (unparseName <$> bs)
<> " -> " <> go 0 e
& pprec 0 p
go p (Let r bs e) = mconcat [lw," { ",bs'," } in ",go 0 e]
& pprec 0 p
where
lw = case r of { NonRec -> "let"; Rec -> "letrec" }
bs' = srci "; " $ unparseBinding <$> bs
go p (Case e as) = mconcat ["case ",go 0 e," of {",as',"}"]
& pprec 0 p
where as' = srci "; " (unparseAlter <$> as)
assocApp (App f x) = assocApp f ++ [x]
assocApp f = [f]
srci :: ProgramSrc -> [ProgramSrc] -> ProgramSrc
srci = coerce T.intercalate
unparseBinding :: Binding' -> ProgramSrc
unparseBinding (k := v) = mconcat [unparseName k, " = ", unparseExpr v]
unparseLit :: Lit -> ProgramSrc
unparseLit (IntL n) = srcShow n
srcShow :: (Show a) => a -> ProgramSrc
srcShow = coerce . T.pack . show
unparseAlter :: Alter' -> ProgramSrc
unparseAlter (Alter (AltData t) as e) = srcShow t <> " " <> coerce (T.unwords as)
<> " -> " <> unparseExpr e

17
tst/GMSpec.hs
View File

@@ -21,28 +21,21 @@ spec = do
resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1) resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1)
it "should correctly evaluate arbitrary arithmetic" $ do it "should correctly evaluate arbitrary arithmetic" $ do
property $ \e -> withMaxSuccess 40 $ property $ \e ->
let arithRes = Just (evalArith e) let arithRes = Just (evalArith e)
coreRes = evalCore e coreRes = evalCore e
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)

14
tst/Rlp/HindleyMilnerSpec.hs
View File

@@ -1,14 +0,0 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
module Rlp.HindleyMilnerSpec
( spec
)
where
--------------------------------------------------------------------------------
import Test.Hspec
import Rlp.TH
import Rlp.HindleyMilner
--------------------------------------------------------------------------------
spec :: Spec
spec = undefined

8
visualisers/hmvis/.gitignore vendored
View File

@@ -1,8 +0,0 @@
/public/js
/node_modules
/target
/.shadow-cljs
/*.iml
/.nrepl-port
/.idea

2006
visualisers/hmvis/package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

11
visualisers/hmvis/package.json
View File

@@ -1,11 +0,0 @@
{
"devDependencies": {
"shadow-cljs": "^2.26.2"
},
"dependencies": {
"ace-builds": "^1.32.7",
"react": "16.13.0",
"react-ace": "^10.1.0",
"react-dom": "16.13.0"
}
}

99
visualisers/hmvis/public/css/main.css
View File

@@ -1,99 +0,0 @@
@import "solarized.css";
html, body
{ height: 100%
}
body {
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, Cantarell, 'Open Sans', 'Helvetica Neue', sans-serif;
overflow: hidden;
}
.editor-container
{ position: relative
; height: 80vh
}
#editor
{ width: 100%;
; height: 100%
; position: relative
}
#type-check-button {
position: fixed;
top: 0;
left: 50%;
z-index: 2;
/* margin: 0 auto; */
transform: translateX(-50%);
}
#type-check-output
{ background: green
; width: 100%
; height: 100%
}
.main-view-container
{ columns: 2 auto;
}
.split {
height: 100%;
width: 50%;
position: fixed;
z-index: 1;
top: 0;
overflow-x: hidden;
padding-top: 20px;
}
.left {
left: 0;
}
.right {
right: 0;
}
.annotation-wrapper
{ display: inline-flex
; flex-direction: column
/* ; border-style: solid */
/* ; border-width: 0 0 0.45em 0 */
}
.typed-wrapper
{ display: inline-block
}
.annotation-wrapper .annotation
{ position: relative
; bottom: 0
; min-height: 0.60em
}
.annotation-text
{ display: none
}
.annotation.hovering > .annotation-text
{ display: inline-block
}
.code-wrapper
{ display: inline-block
}
code
{ font-family: monospace
; font-size: 1em
}
/* .typed-wrapper.hovering > .code-wrapper */
/* { border-width: 0.2em */
/* ; border-style: solid */
/* } */

303
visualisers/hmvis/public/css/solarized.css
View File

@@ -1,303 +0,0 @@
@import url(http://fonts.googleapis.com/css?family=PT+Sans);
@import url(http://fonts.googleapis.com/css?family=PT+Sans+Narrow:400,700);
article,
aside,
details,
figcaption,
figure,
footer,
header,
hgroup,
nav,
section,
summary {
display: block;
}
audio,
canvas,
video {
display: inline-block;
}
audio:not([controls]) {
display: none;
height: 0;
}
[hidden] {
display: none;
}
html {
font-family: sans-serif;
-webkit-text-size-adjust: 100%;
-ms-text-size-adjust: 100%;
}
body {
margin: 0;
}
a:focus {
outline: thin dotted;
}
a:active,
a:hover {
outline: 0;
}
h1 {
font-size: 2em;
}
abbr[title] {
border-bottom: 1px dotted;
}
b,
strong {
font-weight: bold;
}
dfn {
font-style: italic;
}
mark {
background: #ff0;
color: #000;
}
code,
kbd,
pre,
samp {
font-family: monospace, serif;
font-size: 1em;
}
pre {
white-space: pre-wrap;
word-wrap: break-word;
}
q {
quotes: "\201C" "\201D" "\2018" "\2019";
}
small {
font-size: 80%;
}
sub,
sup {
font-size: 75%;
line-height: 0;
position: relative;
vertical-align: baseline;
}
sup {
top: -0.5em;
}
sub {
bottom: -0.25em;
}
img {
border: 0;
}
svg:not(:root) {
overflow: hidden;
}
figure {
margin: 0;
}
fieldset {
border: 1px solid #c0c0c0;
margin: 0 2px;
padding: 0.35em 0.625em 0.75em;
}
legend {
border: 0;
padding: 0;
}
button,
input,
select,
textarea {
font-family: inherit;
font-size: 100%;
margin: 0;
}
button,
input {
line-height: normal;
}
button,
html input[type="button"],
input[type="reset"],
input[type="submit"] {
-webkit-appearance: button;
cursor: pointer;
}
button[disabled],
input[disabled] {
cursor: default;
}
input[type="checkbox"],
input[type="radio"] {
box-sizing: border-box;
padding: 0;
}
input[type="search"] {
-webkit-appearance: textfield;
-moz-box-sizing: content-box;
-webkit-box-sizing: content-box;
box-sizing: content-box;
}
input[type="search"]::-webkit-search-cancel-button,
input[type="search"]::-webkit-search-decoration {
-webkit-appearance: none;
}
button::-moz-focus-inner,
input::-moz-focus-inner {
border: 0;
padding: 0;
}
textarea {
overflow: auto;
vertical-align: top;
}
table {
border-collapse: collapse;
border-spacing: 0;
}
html {
font-family: 'PT Sans', sans-serif;
}
pre,
code {
font-family: 'Inconsolata', sans-serif;
}
h1,
h2,
h3,
h4,
h5,
h6 {
font-family: 'PT Sans Narrow', sans-serif;
font-weight: 700;
}
html {
background-color: #eee8d5;
color: #657b83;
margin: 1em;
}
body {
background-color: #fdf6e3;
margin: 0 auto;
max-width: 23cm;
border: 1pt solid #93a1a1;
padding: 1em;
}
code {
background-color: #eee8d5;
padding: 2px;
}
a {
color: #b58900;
}
a:visited {
color: #cb4b16;
}
a:hover {
color: #cb4b16;
}
h1 {
color: #d33682;
}
h2,
h3,
h4,
h5,
h6 {
color: #859900;
}
pre {
background-color: #fdf6e3;
color: #657b83;
border: 1pt solid #93a1a1;
padding: 1em;
box-shadow: 5pt 5pt 8pt #eee8d5;
}
pre code {
background-color: #fdf6e3;
}
h1 {
font-size: 2.8em;
}
h2 {
font-size: 2.4em;
}
h3 {
font-size: 1.8em;
}
h4 {
font-size: 1.4em;
}
h5 {
font-size: 1.3em;
}
h6 {
font-size: 1.15em;
}
.tag {
background-color: #eee8d5;
color: #d33682;
padding: 0 0.2em;
}
.todo,
.next,
.done {
color: #fdf6e3;
background-color: #dc322f;
padding: 0 0.2em;
}
.tag {
-webkit-border-radius: 0.35em;
-moz-border-radius: 0.35em;
border-radius: 0.35em;
}
.TODO {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #2aa198;
}
.NEXT {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #268bd2;
}
.ACTIVE {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #268bd2;
}
.DONE {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #859900;
}
.WAITING {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #cb4b16;
}
.HOLD {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #d33682;
}
.NOTE {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #d33682;
}
.CANCELLED {
-webkit-border-radius: 0.2em;
-moz-border-radius: 0.2em;
border-radius: 0.2em;
background-color: #859900;
}

22
visualisers/hmvis/public/index.html
View File

@@ -1,22 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<link rel="stylesheet" href="/css/main.css">
<title>Hindley-Milner</title>
<style type="text/css" media="screen">
</style>
</head>
<body>
<div id="mount">
<div id="editor">
</div>
</div>
<script src="/js/main.js"></script>
</body>
</html>

27
visualisers/hmvis/shadow-cljs.edn
View File

@@ -1,27 +0,0 @@
;; shadow-cljs configuration
{:source-paths
["src/"]
:dependencies
[[cider/cider-nrepl "0.24.0"]
[nilenso/wscljs "0.2.0"]
[org.clojure/core.match "1.1.0"]
[binaryage/oops "0.7.2"]
[reagent "0.10.0"]
[cljsjs/react "17.0.2-0"]
[cljsjs/react-dom "17.0.2-0"]
[cljsx "1.0.0"]]
:dev-http
{8020 "public"}
:builds
{:app
{:target :browser
:output-dir "public/js"
:asset-path "/js"
:modules
{:main ; becomes public/js/main.js
{:init-fn main/init}}}}}

142
visualisers/hmvis/src/hmvis/annotated.cljs
View File

@@ -1,142 +0,0 @@
(ns hmvis.annotated
(:require [cljs.core.match :refer-macros [match]]
[cljsx.core :refer [jsx> react> defcomponent]]
[react :as react]
[react-dom :as react-dom]
[reagent.core :as r]
[reagent.dom :as rdom]
[clojure.pprint :refer [cl-format]]
[hmvis.ppr :as ppr]
[clojure.pprint :refer [pprint]]
[clojure.string :as str]))
(defonce tc-input (r/atom nil))
(defonce current-annotation-text (r/atom nil))
(defn unicodify [s]
(str/replace s #"->" "→"))
(defn punctuate [p & as]
(match as
[] ""
_ (reduce #(str %1 p %2) as)))
(defn hsep [& as]
(apply punctuate " " as))
(defn maybe-parens [c s]
(if c
[:<> "(" s ")"]
s))
(defn formatln [fs & rest]
(apply cl-format true (str fs "~%") rest))
(def nesting-rainbow (cycle ["red" "orange" "yellow"
"green" "blue" "purple"]))
(defn text-colour-by-background [colour]
(match colour
"yellow" "black"
_ "white"))
(defn Annotation [colour text hovering?]
[:div {:class (if @hovering?
"annotation hovering"
"annotation")
:on-mouse-enter #(reset! hovering? true)
:on-mouse-leave #(reset! hovering? false)
:style {:background colour
:color (text-colour-by-background colour)}}
[:div {:class "annotation-text"}
text]])
(defn Typed [colour t child]
(let [hovering? (r/atom false)]
(fn []
[:div {:class "annotation-wrapper"}
[:div {:class (if @hovering?
"typed-wrapper hovering"
"typed-wrapper")
}
[:div {:class "code-wrapper"} child]]
[Annotation colour (unicodify t) hovering?]])))
(declare Expr)
(defn LambdaExpr [colours binds body]
[:<>
[:code
(hsep "λ" (apply hsep binds) "-> ")]
[Expr colours 0 body]])
(defn VarExpr [var-id]
[:code var-id])
(defn AppExpr [colours f x]
[:<> [Expr colours ppr/app-prec f]
" "
[Expr colours ppr/app-prec1 x]])
(defn let-or-letrec [rec]
(match rec
"Rec" "letrec"
"NonRec" "let"))
(defn Pat [colours p {:keys [tag contents]}]
(match tag
"VarP" contents))
(defn Binding [colours {:keys [tag contents]}]
(match tag
"VarB" (let [[p v] contents]
[:<> [Pat colours 0 p] " = " [Expr colours 0 v]])))
(defn LetExpr [colours rec bs e]
[:<> (let-or-letrec rec)
" "
(apply punctuate "; " (map (partial Binding colours) bs))
" in "
(Expr colours 0 e)])
(defn LitExpr [_ l]
[:code (str l)])
(defn Expr [[c & colours] p {e :e t :type}]
(match e
{:InL {:tag "LamF" :contents [bs body & _]}}
(maybe-parens (< ppr/app-prec1 p)
[Typed c t [LambdaExpr colours bs body]])
{:InL {:tag "VarF" :contents var-id}}
[Typed c t [VarExpr var-id]]
{:InL {:tag "AppF" :contents [f x]}}
(maybe-parens (< ppr/app-prec p)
[Typed c t [AppExpr colours f x]])
{:InR {:tag "LetEF" :contents [r bs body]}}
(maybe-parens (< ppr/app-prec1 p)
[Typed c t [LetExpr colours r bs body]])
{:InL {:tag "LitF" :contents l}}
[Typed c t [LitExpr colours l]]
:else [:code "<expr>"]))
(def rainbow-cycle (cycle ["red"
"orange"
"yellow"
"green"
"blue"
"violet"]))
(defn render-decl [{name :name body :body}]
[:code {:key name :display "block"}
(str name " = ") [Expr rainbow-cycle 0 body] #_ (render-expr body)
[:br]])
(defn TypeChecker []
[:div
(map render-decl (or @tc-input []))])
; (defn init []
; (rdom/render [type-checker]
; (js/document.querySelector "#output")))

41
visualisers/hmvis/src/hmvis/ppr.cljs
View File

@@ -1,41 +0,0 @@
(ns hmvis.ppr
(:require [cljs.core.match :refer-macros [match]]))
(def app-prec 10)
(def app-prec1 11)
(defn- maybe-parens [c s]
(if c
(str "(" s ")")
s))
(defn- hsep [& as]
(let [f (fn [a b] (str a " " b))]
(reduce f as)))
(declare expr)
(defn lambda-expr [binds body]
(hsep "λ" (apply hsep binds) "->" (expr body)))
(defn app-expr [f x]
(hsep (expr app-prec f) (expr app-prec1 x)))
(defn var-expr [var-id]
var-id)
(defn expr
([exp] (expr 0 exp))
([p {e :e}]
(match e
{:InL {:tag "LamF" :contents [bs body & _]}}
(maybe-parens (< app-prec1 p)
(lambda-expr bs body))
{:InL {:tag "VarF" :contents var-id}}
(var-expr var-id)
{:InL {:tag "AppF" :contents [f x]}}
(maybe-parens (< app-prec p)
(app-expr f x))
:else [:code "<expr>"])))

103
visualisers/hmvis/src/main.cljs
View File

@@ -1,103 +0,0 @@
(ns main
(:require [clojure.spec.alpha :as s]
["react-ace$default" :as AceEditor]
["ace-builds/src-noconflict/mode-haskell"]
["ace-builds/src-noconflict/theme-solarized_light"]
["ace-builds/src-noconflict/keybinding-vim"]
[wscljs.client :as ws]
[wscljs.format :as fmt]
[cljs.core.match :refer-macros [match]]
[hmvis.annotated :as annotated]
[reagent.core :as r]
[reagent.dom :as rdom]))
; (def *editor
; (doto (js/ace.edit "editor")
; (.setTheme "ace/theme/solarized_light")
; (.setKeyboardHandler "ace/keyboard/vim")
; (.setOption "mode" "ace/mode/haskell")))
(def *output (.querySelector js/document "#output"))
(defn display-errors [es]
(doseq [{{e :contents} :diagnostic} es]
(let [fmte (map #(str " • " % "\n") e)]
(js/console.warn (apply str "message from rlpc:\n" fmte)))))
(defn with-success [f ma]
(match ma
{:errors es :result nil} (display-errors es)
{:errors es :result a} (do (display-errors es)
(f a))))
(defn on-message [e]
(let [r (js->clj (js/JSON.parse (.-data e)) :keywordize-keys true)]
(match r
{:tag "Annotated" :contents c}
(with-success #(reset! annotated/tc-input %) c)
:else
(js/console.warn "unrecognisable response from rlp"))))
(defonce *socket (ws/create "ws://127.0.0.1:9002"
{:on-message on-message
:on-open #(println "socket opened")
:on-close #(println "socket closed")
:on-error #(println "error: " %)}))
(defn send [msg]
(ws/send *socket msg fmt/json))
(defonce *editor nil)
(defn TypeCheckButton []
[:button {:id "type-check-button"
:on-click #(send {:command "annotate"
:source (.getValue *editor)})}
"type-check"])
(defn Editor []
[:div {:class "editor-container"}
[(r/adapt-react-class AceEditor)
{:mode "haskell"
:theme "solarized_light"
:keyboardHandler "vim"
:defaultValue (str "id = \\x -> x\n"
"flip f x y = f y x\n"
"fix f = letrec x = f x in x")
:style {:width "100%"
:height "100%"}
:on-load (fn [editor]
(set! *editor editor)
(set! (.. editor -container -style -resize) "both")
(js/document.addEventListener
"mouseup"
#(.resize editor)))
:name "editor"} ]])
(defn Main []
[:<>
[:div {:class "main-view-container"}
[TypeCheckButton]
[Editor]
[annotated/TypeChecker]
#_ [:div {:id "type-check-output"}
"doge soge quoge"]]
#_ [annotated/TypeChecker]])
;; start is called by init and after code reloading finishes
(defn ^:dev/after-load start []
(rdom/render [Main]
(js/document.getElementById "mount"))
(js/console.log "start"))
(defn init []
;; init is called ONCE when the page loads
;; this is called in the index.html and must be exported
;; so it is available even in :advanced release builds
(js/console.log "init")
(start))
;; this is called before any code is reloaded
(defn ^:dev/before-load stop []
(js/console.log "stop"))