Compare commits
10 Commits
gm-visuali
...
no-ttg
| Author | SHA1 | Date | |
|---|---|---|---|
|
09f393af89 | ||
|
|
e63e34a3d8 | ||
|
|
13e8701b8a | ||
|
|
66c3d878c2 | ||
|
|
820bd7cdbc | ||
|
|
9297d815d6 | ||
|
|
910cf66468 | ||
|
|
da81a5a98e | ||
|
|
caeec216b5 | ||
|
|
e9cab1ddaf |
@@ -1,16 +1,14 @@
|
|||||||
GHC_VERSION = $(shell ghc --numeric-version)
|
|
||||||
HAPPY = happy
|
HAPPY = happy
|
||||||
HAPPY_OPTS = -a -g -c -i/tmp/t.info
|
HAPPY_OPTS = -a -g -c -i/tmp/t.info
|
||||||
ALEX = alex
|
ALEX = alex
|
||||||
ALEX_OPTS = -g
|
ALEX_OPTS = -g
|
||||||
|
|
||||||
SRC = src
|
SRC = src
|
||||||
CABAL_BUILD = $(shell ./find-build.clj)
|
CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
|
||||||
|
|
||||||
all: parsers lexers
|
all: parsers lexers
|
||||||
|
|
||||||
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
|
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
|
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
|
||||||
|
|
||||||
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
|
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
|
||||||
|
|||||||
@@ -1,24 +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 GM
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
driver :: RLPCIO ()
|
|
||||||
driver = forFiles_ $ \f ->
|
|
||||||
withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
|
|
||||||
|
|
||||||
driverSource :: T.Text -> RLPCIO ()
|
|
||||||
driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
|
|
||||||
where
|
|
||||||
printRes = liftIO . print . view _1
|
|
||||||
|
|
||||||
140
app.old/Main.hs
140
app.old/Main.hs
@@ -1,140 +0,0 @@
|
|||||||
{-# LANGUAGE BlockArguments, LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
module Main where
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
import Compiler.RLPC
|
|
||||||
import Compiler.RlpcError
|
|
||||||
import Control.Exception
|
|
||||||
import Options.Applicative hiding (ParseError)
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Data.HashSet qualified as S
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Text qualified as T
|
|
||||||
import Data.Text.IO qualified as TIO
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe (listToMaybe)
|
|
||||||
import System.IO
|
|
||||||
import System.Exit (exitSuccess)
|
|
||||||
import Core
|
|
||||||
import TI
|
|
||||||
import GM
|
|
||||||
import Control.Lens.Combinators hiding (argument)
|
|
||||||
|
|
||||||
import CoreDriver qualified
|
|
||||||
import RlpDriver qualified
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
optParser :: ParserInfo RLPCOptions
|
|
||||||
optParser = info (helper <*> options)
|
|
||||||
( fullDesc
|
|
||||||
<> progDesc "Compile rl' programs"
|
|
||||||
<> header "rlpc - The Inglorious rl' Compiler"
|
|
||||||
)
|
|
||||||
|
|
||||||
options :: Parser RLPCOptions
|
|
||||||
options = RLPCOptions
|
|
||||||
{- --log, -l -}
|
|
||||||
<$> optional # strOption
|
|
||||||
( long "log"
|
|
||||||
<> short 'l'
|
|
||||||
<> metavar "FILE"
|
|
||||||
<> help "output dumps to FILE. stderr is used if unset"
|
|
||||||
)
|
|
||||||
{- -d -}
|
|
||||||
<*> fmap S.fromList # many # option debugFlagReader
|
|
||||||
( short 'd'
|
|
||||||
<> help "pass debug flags"
|
|
||||||
<> metavar "DEBUG FLAG"
|
|
||||||
)
|
|
||||||
{- -f -}
|
|
||||||
<*> fmap S.fromList # many # option compilerFlagReader
|
|
||||||
( short 'f'
|
|
||||||
<> help "pass compilation flags"
|
|
||||||
<> metavar "COMPILATION FLAG"
|
|
||||||
)
|
|
||||||
{- --evaluator, -e -}
|
|
||||||
<*> option evaluatorReader
|
|
||||||
( long "evaluator"
|
|
||||||
<> short 'e'
|
|
||||||
<> metavar "gm|ti"
|
|
||||||
<> value EvaluatorGM
|
|
||||||
<> help "the intermediate layer used to model evaluation"
|
|
||||||
)
|
|
||||||
<*> option auto
|
|
||||||
( long "heap-trigger"
|
|
||||||
<> metavar "INT"
|
|
||||||
<> help "the number of nodes allowed on the heap before\
|
|
||||||
\triggering the garbage collector"
|
|
||||||
<> value 50
|
|
||||||
)
|
|
||||||
<*> optional # option languageReader
|
|
||||||
( long "language"
|
|
||||||
<> short 'x'
|
|
||||||
<> metavar "rlp|core"
|
|
||||||
<> help "the language to be compiled -- see README"
|
|
||||||
)
|
|
||||||
<*> some (argument str $ metavar "FILES...")
|
|
||||||
where
|
|
||||||
infixr 9 #
|
|
||||||
f # x = f x
|
|
||||||
|
|
||||||
languageReader :: ReadM Language
|
|
||||||
languageReader = maybeReader $ \case
|
|
||||||
"rlp" -> Just LanguageRlp
|
|
||||||
"core" -> Just LanguageCore
|
|
||||||
"rl" -> Just LanguageRlp
|
|
||||||
"cr" -> Just LanguageCore
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
debugFlagReader :: ReadM DebugFlag
|
|
||||||
debugFlagReader = str
|
|
||||||
|
|
||||||
compilerFlagReader :: ReadM CompilerFlag
|
|
||||||
compilerFlagReader = str
|
|
||||||
|
|
||||||
evaluatorReader :: ReadM Evaluator
|
|
||||||
evaluatorReader = maybeReader $ \case
|
|
||||||
"gm" -> Just EvaluatorGM
|
|
||||||
"ti" -> Just EvaluatorTI
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
mmany :: (Alternative f, Monoid m) => f m -> f m
|
|
||||||
mmany v = liftA2 (<>) v (mmany v)
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
opts <- execParser optParser
|
|
||||||
void $ evalRLPCIO opts dispatch
|
|
||||||
|
|
||||||
dispatch :: RLPCIO ()
|
|
||||||
dispatch = getLang >>= \case
|
|
||||||
Just LanguageCore -> CoreDriver.driver
|
|
||||||
Just LanguageRlp -> RlpDriver.driver
|
|
||||||
Nothing -> addFatal err
|
|
||||||
where
|
|
||||||
-- TODO: why didn't i make the srcspan optional LOL
|
|
||||||
err = errorMsg (SrcSpan 0 0 0 0) $ Text
|
|
||||||
[ "Could not determine source language from filetype."
|
|
||||||
, "Possible Solutions:\n\
|
|
||||||
\ Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
|
|
||||||
\ Specify a language with `rlpc -x core' or `rlpc -x rlp'"
|
|
||||||
]
|
|
||||||
where
|
|
||||||
getLang = liftA2 (<|>)
|
|
||||||
(view rlpcLanguage)
|
|
||||||
-- TODO: we only check the first file lol
|
|
||||||
((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
|
|
||||||
|
|
||||||
|
|
||||||
driver :: RLPCIO ()
|
|
||||||
driver = undefined
|
|
||||||
|
|
||||||
inferLanguage :: FilePath -> Maybe Language
|
|
||||||
inferLanguage fp
|
|
||||||
| ".rl" `isSuffixOf` fp = Just LanguageRlp
|
|
||||||
| ".cr" `isSuffixOf` fp = Just LanguageCore
|
|
||||||
| otherwise = Nothing
|
|
||||||
|
|
||||||
@@ -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 >=> desugarRlpProgR >=> evalProgR)
|
|
||||||
|
|
||||||
@@ -10,7 +10,6 @@ import Control.Lens.Combinators
|
|||||||
|
|
||||||
import Core.Lex
|
import Core.Lex
|
||||||
import Core.Parse
|
import Core.Parse
|
||||||
-- import Core.SystemF
|
|
||||||
import GM
|
import GM
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
@@ -19,8 +18,7 @@ driver = forFiles_ $ \f ->
|
|||||||
withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
|
withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
|
||||||
|
|
||||||
driverSource :: T.Text -> RLPCIO ()
|
driverSource :: T.Text -> RLPCIO ()
|
||||||
driverSource = lexCoreR >=> parseCoreProgR
|
driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
|
||||||
>=> evalProgR >=> printRes
|
|
||||||
where
|
where
|
||||||
printRes = liftIO . print . view _1
|
printRes = liftIO . print . view _1
|
||||||
|
|
||||||
|
|||||||
12
app/Main.hs
12
app/Main.hs
@@ -2,7 +2,6 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Main where
|
module Main where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
import Control.Lens hiding (argument)
|
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Compiler.RlpcError
|
import Compiler.RlpcError
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
@@ -24,7 +23,6 @@ import Control.Lens.Combinators hiding (argument)
|
|||||||
|
|
||||||
import CoreDriver qualified
|
import CoreDriver qualified
|
||||||
import RlpDriver qualified
|
import RlpDriver qualified
|
||||||
import Server qualified
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
optParser :: ParserInfo RLPCOptions
|
optParser :: ParserInfo RLPCOptions
|
||||||
@@ -76,11 +74,7 @@ options = RLPCOptions
|
|||||||
<> metavar "rlp|core"
|
<> metavar "rlp|core"
|
||||||
<> help "the language to be compiled -- see README"
|
<> help "the language to be compiled -- see README"
|
||||||
)
|
)
|
||||||
<*> switch
|
<*> some (argument str $ metavar "FILES...")
|
||||||
( long "server"
|
|
||||||
<> short 's'
|
|
||||||
)
|
|
||||||
<*> many (argument str $ metavar "FILES...")
|
|
||||||
where
|
where
|
||||||
infixr 9 #
|
infixr 9 #
|
||||||
f # x = f x
|
f # x = f x
|
||||||
@@ -113,9 +107,7 @@ mmany v = liftA2 (<>) v (mmany v)
|
|||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
opts <- execParser optParser
|
opts <- execParser optParser
|
||||||
if opts ^. rlpcServer
|
void $ evalRLPCIO opts dispatch
|
||||||
then Server.server
|
|
||||||
else void $ evalRLPCIO opts dispatch
|
|
||||||
|
|
||||||
dispatch :: RLPCIO ()
|
dispatch :: RLPCIO ()
|
||||||
dispatch = getLang >>= \case
|
dispatch = getLang >>= \case
|
||||||
|
|||||||
@@ -15,5 +15,5 @@ import GM
|
|||||||
|
|
||||||
driver :: RLPCIO ()
|
driver :: RLPCIO ()
|
||||||
driver = forFiles_ $ \f ->
|
driver = forFiles_ $ \f ->
|
||||||
withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
|
withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
|
||||||
|
|
||||||
|
|||||||
@@ -1,92 +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, empty)
|
|
||||||
import Data.Aeson ( ToJSON(..), Value, (.:)
|
|
||||||
, FromJSON(..), encode, withObject
|
|
||||||
, decodeStrictText)
|
|
||||||
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 Compiler.JustRun
|
|
||||||
import GM
|
|
||||||
|
|
||||||
-- 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
|
|
||||||
| Evaluate Text
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
instance FromJSON Command where
|
|
||||||
parseJSON = withObject "command object" $ \v -> do
|
|
||||||
cmd :: Text <- v .: "command"
|
|
||||||
case cmd of
|
|
||||||
"evaluate" -> Evaluate <$> v .: "source"
|
|
||||||
"annotate" -> Annotate <$> v .: "source"
|
|
||||||
"partially-annotate" -> PartiallyAnnotate <$> v .: "source"
|
|
||||||
_ -> empty
|
|
||||||
|
|
||||||
data Response = Annotated Value
|
|
||||||
| PartiallyAnnotated Value
|
|
||||||
| Evaluated [GmState]
|
|
||||||
| Error 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)
|
|
||||||
= error "i'm a shitty programmer! try again with the dev branch lmfao"
|
|
||||||
|
|
||||||
respond (Evaluate s)
|
|
||||||
= justLexParseGmEval (T.unpack s)
|
|
||||||
& either (Error . toJSON) Evaluated
|
|
||||||
|
|
||||||
@@ -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)))
|
|
||||||
|
|
||||||
21
rlp.cabal
21
rlp.cabal
@@ -32,6 +32,8 @@ library
|
|||||||
, Core.HindleyMilner
|
, Core.HindleyMilner
|
||||||
, Control.Monad.Errorful
|
, Control.Monad.Errorful
|
||||||
, Rlp.Syntax
|
, Rlp.Syntax
|
||||||
|
, Rlp.Syntax.Backstage
|
||||||
|
, Rlp.Syntax.Types
|
||||||
-- , Rlp.Parse.Decls
|
-- , Rlp.Parse.Decls
|
||||||
, Rlp.Parse
|
, Rlp.Parse
|
||||||
, Rlp.Parse.Associate
|
, Rlp.Parse.Associate
|
||||||
@@ -50,17 +52,17 @@ library
|
|||||||
build-tool-depends: happy:happy, alex:alex
|
build-tool-depends: happy:happy, alex:alex
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base >=4.17 && <4.21
|
build-depends: base >=4.17 && <4.20
|
||||||
-- required for happy
|
-- required for happy
|
||||||
, array >= 0.5.5 && < 0.6
|
, array >= 0.5.5 && < 0.6
|
||||||
, containers >= 0.6.7 && < 0.7
|
, containers >= 0.6.7 && < 0.7
|
||||||
, template-haskell >= 2.20.0 && < 2.23
|
, template-haskell >= 2.20.0 && < 2.21
|
||||||
, pretty >= 1.1.3 && < 1.2
|
, pretty >= 1.1.3 && < 1.2
|
||||||
, data-default >= 0.7.1 && < 0.8
|
, data-default >= 0.7.1 && < 0.8
|
||||||
, data-default-class >= 0.1.2 && < 0.2
|
, data-default-class >= 0.1.2 && < 0.2
|
||||||
, hashable >= 1.4.3 && < 1.5
|
, hashable >= 1.4.3 && < 1.5
|
||||||
, mtl >= 2.3.1 && < 2.4
|
, mtl >= 2.3.1 && < 2.4
|
||||||
, text >= 2.0.2 && < 2.3
|
, text >= 2.0.2 && < 2.1
|
||||||
, unordered-containers >= 0.2.20 && < 0.3
|
, unordered-containers >= 0.2.20 && < 0.3
|
||||||
, recursion-schemes >= 5.2.2 && < 5.3
|
, recursion-schemes >= 5.2.2 && < 5.3
|
||||||
, data-fix >= 0.3.2 && < 0.4
|
, data-fix >= 0.3.2 && < 0.4
|
||||||
@@ -73,14 +75,11 @@ library
|
|||||||
, effectful-core ^>=2.3.0.0
|
, effectful-core ^>=2.3.0.0
|
||||||
, deriving-compat ^>=0.6.0
|
, deriving-compat ^>=0.6.0
|
||||||
, these >=0.2 && <2.0
|
, these >=0.2 && <2.0
|
||||||
, aeson
|
, free >=5.2
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
|
|
||||||
ghc-options:
|
|
||||||
-fdefer-typed-holes
|
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
TypeFamilies
|
TypeFamilies
|
||||||
@@ -90,14 +89,12 @@ library
|
|||||||
DerivingVia
|
DerivingVia
|
||||||
StandaloneDeriving
|
StandaloneDeriving
|
||||||
DerivingStrategies
|
DerivingStrategies
|
||||||
PartialTypeSignatures
|
|
||||||
|
|
||||||
executable rlpc
|
executable rlpc
|
||||||
import: warnings
|
import: warnings
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
other-modules: RlpDriver
|
other-modules: RlpDriver
|
||||||
, CoreDriver
|
, CoreDriver
|
||||||
, Server
|
|
||||||
|
|
||||||
build-depends: base >=4.17.0.0 && <4.20.0.0
|
build-depends: base >=4.17.0.0 && <4.20.0.0
|
||||||
, rlp
|
, rlp
|
||||||
@@ -105,9 +102,7 @@ executable rlpc
|
|||||||
, mtl >= 2.3.1 && < 2.4
|
, mtl >= 2.3.1 && < 2.4
|
||||||
, unordered-containers >= 0.2.20 && < 0.3
|
, unordered-containers >= 0.2.20 && < 0.3
|
||||||
, lens >=5.2.3 && <6.0
|
, lens >=5.2.3 && <6.0
|
||||||
, text >= 2.0.2 && < 2.3
|
, text >= 2.0.2 && < 2.1
|
||||||
, aeson
|
|
||||||
, websockets
|
|
||||||
|
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
@@ -124,8 +119,10 @@ test-suite rlp-test
|
|||||||
, QuickCheck
|
, QuickCheck
|
||||||
, hspec ==2.*
|
, hspec ==2.*
|
||||||
, microlens
|
, microlens
|
||||||
|
, lens >=5.2.3 && <6.0
|
||||||
other-modules: Arith
|
other-modules: Arith
|
||||||
, GMSpec
|
, GMSpec
|
||||||
, Core.HindleyMilnerSpec
|
, Core.HindleyMilnerSpec
|
||||||
|
, Compiler.TypesSpec
|
||||||
build-tool-depends: hspec-discover:hspec-discover
|
build-tool-depends: hspec-discover:hspec-discover
|
||||||
|
|
||||||
|
|||||||
@@ -12,7 +12,6 @@ module Compiler.JustRun
|
|||||||
, justParseCore
|
, justParseCore
|
||||||
, justTypeCheckCore
|
, justTypeCheckCore
|
||||||
, justHdbg
|
, justHdbg
|
||||||
, justLexParseGmEval
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -48,10 +47,6 @@ justParseCore s = parse (T.pack s)
|
|||||||
& rlpcToEither
|
& rlpcToEither
|
||||||
where parse = lexCoreR >=> parseCoreProgR
|
where parse = lexCoreR >=> parseCoreProgR
|
||||||
|
|
||||||
justLexParseGmEval :: String -> Either [MsgEnvelope RlpcError] [GmState]
|
|
||||||
justLexParseGmEval = parse >>> fmap (compile >>> eval) >>> rlpcToEither
|
|
||||||
where parse = (T.pack >>> lexCoreR) >=> parseCoreProgR
|
|
||||||
|
|
||||||
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||||
justTypeCheckCore s = typechk (T.pack s)
|
justTypeCheckCore s = typechk (T.pack s)
|
||||||
& rlpcToEither
|
& rlpcToEither
|
||||||
|
|||||||
@@ -26,7 +26,6 @@ module Compiler.RLPC
|
|||||||
, DebugFlag(..), CompilerFlag(..)
|
, DebugFlag(..), CompilerFlag(..)
|
||||||
-- ** Lenses
|
-- ** Lenses
|
||||||
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
|
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
|
||||||
, rlpcServer
|
|
||||||
-- * Misc. MTL-style functions
|
-- * Misc. MTL-style functions
|
||||||
, liftErrorful, hoistRlpcT
|
, liftErrorful, hoistRlpcT
|
||||||
-- * Misc. Rlpc Monad -related types
|
-- * Misc. Rlpc Monad -related types
|
||||||
@@ -121,7 +120,6 @@ data RLPCOptions = RLPCOptions
|
|||||||
, _rlpcEvaluator :: Evaluator
|
, _rlpcEvaluator :: Evaluator
|
||||||
, _rlpcHeapTrigger :: Int
|
, _rlpcHeapTrigger :: Int
|
||||||
, _rlpcLanguage :: Maybe Language
|
, _rlpcLanguage :: Maybe Language
|
||||||
, _rlpcServer :: Bool
|
|
||||||
, _rlpcInputFiles :: [FilePath]
|
, _rlpcInputFiles :: [FilePath]
|
||||||
}
|
}
|
||||||
deriving Show
|
deriving Show
|
||||||
@@ -143,7 +141,6 @@ instance Default RLPCOptions where
|
|||||||
, _rlpcHeapTrigger = 200
|
, _rlpcHeapTrigger = 200
|
||||||
, _rlpcInputFiles = []
|
, _rlpcInputFiles = []
|
||||||
, _rlpcLanguage = Nothing
|
, _rlpcLanguage = Nothing
|
||||||
, _rlpcServer = False
|
|
||||||
}
|
}
|
||||||
|
|
||||||
-- debug flags are passed with -dFLAG
|
-- debug flags are passed with -dFLAG
|
||||||
@@ -223,9 +220,9 @@ docRlpcErr msg = header
|
|||||||
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
||||||
srclines = ["", "<problematic source code>", ""]
|
srclines = ["", "<problematic source code>", ""]
|
||||||
filename = msgColour "<input>"
|
filename = msgColour "<input>"
|
||||||
pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
|
pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
|
||||||
<> ":"
|
<> ":"
|
||||||
<> tshow (msg ^. msgSpan . srcspanColumn)
|
<> tshow (msg ^. msgSpan . srcSpanColumn)
|
||||||
|
|
||||||
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
|
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
|
||||||
<> errorColour "error" <> msgColour ":"
|
<> errorColour "error" <> msgColour ":"
|
||||||
|
|||||||
@@ -23,9 +23,6 @@ import Data.Text qualified as T
|
|||||||
import GHC.Exts (IsString(..))
|
import GHC.Exts (IsString(..))
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Compiler.Types
|
import Compiler.Types
|
||||||
import GHC.Generics ( Generic, Generic1
|
|
||||||
, Generically(..), Generically1(..) )
|
|
||||||
import Data.Aeson (ToJSON1(..), ToJSON(..))
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
data MsgEnvelope e = MsgEnvelope
|
data MsgEnvelope e = MsgEnvelope
|
||||||
@@ -33,18 +30,10 @@ data MsgEnvelope e = MsgEnvelope
|
|||||||
, _msgDiagnostic :: e
|
, _msgDiagnostic :: e
|
||||||
, _msgSeverity :: Severity
|
, _msgSeverity :: Severity
|
||||||
}
|
}
|
||||||
deriving (Functor, Show, Generic, Generic1)
|
deriving (Functor, Show)
|
||||||
|
|
||||||
newtype RlpcError = Text [Text]
|
newtype RlpcError = Text [Text]
|
||||||
deriving (Show, Generic)
|
deriving Show
|
||||||
|
|
||||||
deriving via Generically1 MsgEnvelope
|
|
||||||
instance ToJSON1 MsgEnvelope
|
|
||||||
deriving via Generically (MsgEnvelope e)
|
|
||||||
instance ToJSON e => ToJSON (MsgEnvelope e)
|
|
||||||
|
|
||||||
deriving via Generically RlpcError
|
|
||||||
instance ToJSON RlpcError
|
|
||||||
|
|
||||||
instance IsString RlpcError where
|
instance IsString RlpcError where
|
||||||
fromString = Text . pure . T.pack
|
fromString = Text . pure . T.pack
|
||||||
@@ -58,10 +47,7 @@ instance IsRlpcError RlpcError where
|
|||||||
data Severity = SevWarning
|
data Severity = SevWarning
|
||||||
| SevError
|
| SevError
|
||||||
| SevDebug Text -- ^ Tag
|
| SevDebug Text -- ^ Tag
|
||||||
deriving (Show, Generic)
|
deriving Show
|
||||||
|
|
||||||
deriving via Generically Severity
|
|
||||||
instance ToJSON Severity
|
|
||||||
|
|
||||||
makeLenses ''MsgEnvelope
|
makeLenses ''MsgEnvelope
|
||||||
|
|
||||||
|
|||||||
@@ -1,36 +1,81 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
module Compiler.Types
|
module Compiler.Types
|
||||||
( SrcSpan(..)
|
( SrcSpan(..)
|
||||||
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
|
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
|
||||||
|
, pattern (:<$)
|
||||||
, Located(..)
|
, Located(..)
|
||||||
|
, HasLocation(..)
|
||||||
, _Located
|
, _Located
|
||||||
, located
|
, nolo, nolo'
|
||||||
, nolo
|
|
||||||
, (<<~), (<~>), (<#>)
|
, (<~>), (~>), (~~>), (<~~)
|
||||||
|
|
||||||
|
, comb2, comb3, comb4
|
||||||
|
, lochead
|
||||||
|
|
||||||
-- * Re-exports
|
-- * Re-exports
|
||||||
, Comonad
|
, Comonad(extract)
|
||||||
, Apply
|
, Apply
|
||||||
, Bind
|
, Bind
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
|
|
||||||
import Control.Comonad
|
import Control.Comonad
|
||||||
|
import Control.Comonad.Cofree
|
||||||
|
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
|
||||||
|
import Control.Comonad.Trans.Cofree (CofreeF)
|
||||||
import Data.Functor.Apply
|
import Data.Functor.Apply
|
||||||
import Data.Functor.Bind
|
import Data.Functor.Bind
|
||||||
import Control.Lens hiding ((<<~))
|
import Data.Functor.Compose
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Data.Functor.Foldable
|
||||||
import GHC.Generics ( Generic, Generic1
|
import Data.Semigroup.Foldable
|
||||||
, Generically(..), Generically1(..) )
|
import Data.Fix hiding (cata, ana)
|
||||||
import Data.Aeson (ToJSON1(..), ToJSON(..))
|
import Data.Kind
|
||||||
|
import Control.Lens hiding ((<<~), (:<))
|
||||||
|
|
||||||
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
|
import Data.Function (on)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Token wrapped with a span (line, column, absolute, length)
|
-- | Token wrapped with a span (line, column, absolute, length)
|
||||||
data Located a = Located SrcSpan a
|
data Located a = Located SrcSpan a
|
||||||
deriving (Show, Lift, Functor)
|
deriving (Show, Lift, Functor)
|
||||||
|
|
||||||
located :: Lens (Located a) (Located b) a b
|
data Floc f = Floc SrcSpan (f (Floc f))
|
||||||
located = lens extract ($>)
|
|
||||||
|
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
|
||||||
|
pattern a :<$ b = a Trans.Cofree.:< b
|
||||||
|
|
||||||
|
(<~>) :: a -> b -> SrcSpan
|
||||||
|
(<~>) = undefined
|
||||||
|
|
||||||
|
infixl 5 <~>
|
||||||
|
|
||||||
|
-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
|
||||||
|
-- => a -> b -> b
|
||||||
|
-- a ~> b =
|
||||||
|
(~>) = 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
|
instance Apply Located where
|
||||||
liftF2 f (Located sa p) (Located sb q)
|
liftF2 f (Located sa p) (Located sb q)
|
||||||
@@ -50,56 +95,136 @@ data SrcSpan = SrcSpan
|
|||||||
!Int -- ^ Column
|
!Int -- ^ Column
|
||||||
!Int -- ^ Absolute
|
!Int -- ^ Absolute
|
||||||
!Int -- ^ Length
|
!Int -- ^ Length
|
||||||
deriving (Show, Lift, Generic)
|
deriving (Show, Eq, Lift)
|
||||||
|
|
||||||
deriving via Generically SrcSpan
|
|
||||||
instance ToJSON SrcSpan
|
|
||||||
|
|
||||||
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
||||||
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
||||||
(\ (a,b,c,d) -> SrcSpan a b c d)
|
(\ (a,b,c,d) -> SrcSpan a b c d)
|
||||||
|
|
||||||
srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
|
srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
|
||||||
srcspanLine = tupling . _1
|
srcSpanLine = tupling . _1
|
||||||
srcspanColumn = tupling . _2
|
srcSpanColumn = tupling . _2
|
||||||
srcspanAbs = tupling . _3
|
srcSpanAbs = tupling . _3
|
||||||
srcspanLen = tupling . _4
|
srcSpanLen = tupling . _4
|
||||||
|
|
||||||
-- | debug tool
|
-- | debug tool
|
||||||
nolo :: a -> Located a
|
nolo :: a -> Located a
|
||||||
nolo = Located (SrcSpan 0 0 0 0)
|
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
|
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
|
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
|
||||||
l = min la lb
|
l = min la lb
|
||||||
c = min ca cb
|
c = min ca cb
|
||||||
a = min aa ab
|
a = min aa ab
|
||||||
s = case aa `compare` ab of
|
s = case aa `compare` ab of
|
||||||
EQ -> max sa sb
|
EQ -> max sa sb
|
||||||
LT -> max sa (ab + lb - aa)
|
LT -> max sa (ab + sb - aa)
|
||||||
GT -> max sb (aa + la - ab)
|
GT -> max sb (aa + sa - ab)
|
||||||
|
|
||||||
-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
|
--------------------------------------------------------------------------------
|
||||||
-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
|
|
||||||
|
|
||||||
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
|
data GetOrSet = Get | Set | GetSet
|
||||||
(<<~) = (<<=)
|
|
||||||
|
|
||||||
infixl 4 <<~
|
class CanGet (k :: GetOrSet)
|
||||||
|
class CanSet (k :: GetOrSet) where
|
||||||
|
|
||||||
-- | Similar to '(<*>)', but with a cokleisli arrow.
|
instance CanGet Get
|
||||||
|
instance CanGet GetSet
|
||||||
|
instance CanSet Set
|
||||||
|
instance CanSet GetSet
|
||||||
|
|
||||||
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
|
data GetSetLens (k :: GetOrSet) s t a b :: Type where
|
||||||
mc <~> ma = mc >>- \f -> ma =>> f
|
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
|
||||||
|
|
||||||
infixl 4 <~>
|
type GetSetLens' k s a = GetSetLens k s s a a
|
||||||
|
|
||||||
-- this is getting silly
|
class HasLocation k s | s -> k where
|
||||||
|
-- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
|
||||||
|
getSetLocation :: GetSetLens' k s SrcSpan
|
||||||
|
|
||||||
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
|
type family Access (k :: GetOrSet) f where
|
||||||
fab <#> a = fmap ($ a) fab
|
Access GetSet f = Functor f
|
||||||
|
Access Set f = Settable f
|
||||||
|
Access Get f = (Functor f, Contravariant f)
|
||||||
|
|
||||||
infixl 4 <#>
|
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
|
makePrisms ''Located
|
||||||
|
|
||||||
|
|||||||
@@ -28,27 +28,10 @@ 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
|
import Control.Lens
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import GHC.Generics ( Generic1, Generic
|
|
||||||
, Generically1(..), Generically(..))
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Heap a = Heap [Addr] (Map Addr a)
|
data Heap a = Heap [Addr] (Map Addr a)
|
||||||
deriving (Show, Generic, Generic1)
|
deriving Show
|
||||||
deriving (ToJSON1, FromJSON1)
|
|
||||||
via Generically1 Heap
|
|
||||||
|
|
||||||
instance ToJSON a => ToJSON (Heap a) where
|
|
||||||
toJSON (Heap as m) = toJSON m
|
|
||||||
|
|
||||||
instance FromJSON (Heap a) where
|
|
||||||
parseJSON = _
|
|
||||||
|
|
||||||
-- deriving via Generically (Heap a)
|
|
||||||
-- instance ToJSON a => ToJSON (Heap a)
|
|
||||||
-- deriving via Generically (Heap a)
|
|
||||||
-- instance FromJSON a => FromJSON (Heap a)
|
|
||||||
|
|
||||||
type Addr = Int
|
type Addr = Int
|
||||||
|
|
||||||
|
|||||||
72
src/GM.hs
72
src/GM.hs
@@ -18,8 +18,6 @@ module GM
|
|||||||
, finalStateOf
|
, finalStateOf
|
||||||
, resultOf
|
, resultOf
|
||||||
, resultOfExpr
|
, resultOfExpr
|
||||||
, compile
|
|
||||||
, eval
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -44,12 +42,6 @@ import Data.String (IsString)
|
|||||||
import Data.Heap
|
import Data.Heap
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
|
|
||||||
-- for visualisation
|
|
||||||
import Data.Aeson hiding (Key)
|
|
||||||
import Data.Aeson.Text
|
|
||||||
import GHC.Generics (Generic, Generically(..))
|
|
||||||
|
|
||||||
import Core2Core
|
import Core2Core
|
||||||
import Core
|
import Core
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -86,7 +78,7 @@ data GmState = GmState
|
|||||||
, _gmEnv :: Env
|
, _gmEnv :: Env
|
||||||
, _gmStats :: Stats
|
, _gmStats :: Stats
|
||||||
}
|
}
|
||||||
deriving (Show, Generic)
|
deriving Show
|
||||||
|
|
||||||
type Code = [Instr]
|
type Code = [Instr]
|
||||||
type Stack = [Addr]
|
type Stack = [Addr]
|
||||||
@@ -96,7 +88,7 @@ type GmHeap = Heap Node
|
|||||||
|
|
||||||
data Key = NameKey Name
|
data Key = NameKey Name
|
||||||
| ConstrKey Tag Int
|
| ConstrKey Tag Int
|
||||||
deriving (Show, Eq, Generic)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
-- >> [ref/Instr]
|
-- >> [ref/Instr]
|
||||||
data Instr = Unwind
|
data Instr = Unwind
|
||||||
@@ -119,7 +111,7 @@ data Instr = Unwind
|
|||||||
| Split Int
|
| Split Int
|
||||||
| Print
|
| Print
|
||||||
| Halt
|
| Halt
|
||||||
deriving (Show, Eq, Generic)
|
deriving (Show, Eq)
|
||||||
-- << [ref/Instr]
|
-- << [ref/Instr]
|
||||||
|
|
||||||
data Node = NNum Int
|
data Node = NNum Int
|
||||||
@@ -132,7 +124,7 @@ data Node = NNum Int
|
|||||||
| NUninitialised
|
| NUninitialised
|
||||||
| NConstr Tag [Addr] -- NConstr Tag Components
|
| NConstr Tag [Addr] -- NConstr Tag Components
|
||||||
| NMarked Node
|
| NMarked Node
|
||||||
deriving (Show, Eq, Generic)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
-- TODO: log executed instructions
|
-- TODO: log executed instructions
|
||||||
data Stats = Stats
|
data Stats = Stats
|
||||||
@@ -142,7 +134,7 @@ data Stats = Stats
|
|||||||
, _stsDereferences :: Int
|
, _stsDereferences :: Int
|
||||||
, _stsGCCycles :: Int
|
, _stsGCCycles :: Int
|
||||||
}
|
}
|
||||||
deriving (Show, Generic)
|
deriving Show
|
||||||
|
|
||||||
instance Default Stats where
|
instance Default Stats where
|
||||||
def = Stats 0 0 0 0 0
|
def = Stats 0 0 0 0 0
|
||||||
@@ -186,49 +178,19 @@ hdbgProg p hio = do
|
|||||||
|
|
||||||
evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
|
evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
|
||||||
evalProgR p = do
|
evalProgR p = do
|
||||||
putState `traverse_` states
|
(renderOut . showState) `traverse_` states
|
||||||
putStats sts
|
renderOut . showStats $ sts
|
||||||
pure res
|
pure (res, sts)
|
||||||
where
|
where
|
||||||
|
renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
|
||||||
states = eval . compile $ p
|
states = eval . compile $ p
|
||||||
res@(_, sts) = results states
|
|
||||||
|
|
||||||
putState :: Monad m => GmState -> RLPCT m ()
|
|
||||||
putState st = do
|
|
||||||
addDebugMsg "dump-eval" $ render (showState st) ++ "\n"
|
|
||||||
addDebugMsg "dump-eval-json" $
|
|
||||||
view strict . encodeToLazyText $ st
|
|
||||||
|
|
||||||
putStats :: Monad m => Stats -> RLPCT m ()
|
|
||||||
putStats sts = do
|
|
||||||
addDebugMsg "dump-eval" $ render (showStats sts) ++ "\n"
|
|
||||||
|
|
||||||
results :: [GmState] -> (Node, Stats)
|
|
||||||
results states = (res, sts) where
|
|
||||||
final = last states
|
final = last states
|
||||||
|
|
||||||
sts = final ^. gmStats
|
sts = final ^. gmStats
|
||||||
-- the address of the result should be the one and only stack entry
|
-- the address of the result should be the one and only stack entry
|
||||||
[resAddr] = final ^. gmStack
|
[resAddr] = final ^. gmStack
|
||||||
res = hLookupUnsafe resAddr (final ^. gmHeap)
|
res = hLookupUnsafe resAddr (final ^. gmHeap)
|
||||||
|
|
||||||
-- evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
|
|
||||||
-- evalProgR p = do
|
|
||||||
-- (renderOut . showState) `traverse_` states
|
|
||||||
-- renderOut . showStats $ sts
|
|
||||||
-- pure (res, sts)
|
|
||||||
-- where
|
|
||||||
-- renderOut r = do
|
|
||||||
-- addDebugMsg "dump-eval" $ render r ++ "\n"
|
|
||||||
-- addDebugMsg "dump-eval-json" $
|
|
||||||
-- view strict . encodeToLazyText $ r
|
|
||||||
-- 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
|
||||||
@@ -1098,17 +1060,3 @@ resultOfExpr e = resultOf $
|
|||||||
[ ScDef "main" [] e
|
[ ScDef "main" [] e
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- visualisation
|
|
||||||
|
|
||||||
deriving via Generically Instr instance FromJSON Instr
|
|
||||||
deriving via Generically Instr instance ToJSON Instr
|
|
||||||
deriving via Generically Node instance FromJSON Node
|
|
||||||
deriving via Generically Node instance ToJSON Node
|
|
||||||
deriving via Generically Stats instance FromJSON Stats
|
|
||||||
deriving via Generically Stats instance ToJSON Stats
|
|
||||||
deriving via Generically Key instance FromJSON Key
|
|
||||||
deriving via Generically Key instance ToJSON Key
|
|
||||||
deriving via Generically GmState instance FromJSON GmState
|
|
||||||
deriving via Generically GmState instance ToJSON GmState
|
|
||||||
|
|
||||||
|
|||||||
@@ -8,6 +8,7 @@ module Rlp.Lex
|
|||||||
, Located(..)
|
, Located(..)
|
||||||
, lexToken
|
, lexToken
|
||||||
, lexStream
|
, lexStream
|
||||||
|
, lexStream'
|
||||||
, lexDebug
|
, lexDebug
|
||||||
, lexCont
|
, lexCont
|
||||||
, popLexState
|
, popLexState
|
||||||
@@ -29,6 +30,7 @@ import Data.Word
|
|||||||
import Data.Default
|
import Data.Default
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
|
|
||||||
|
import Compiler.Types
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
}
|
}
|
||||||
@@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a
|
|||||||
lexCont = (lexToken >>=)
|
lexCont = (lexToken >>=)
|
||||||
|
|
||||||
lexStream :: P [RlpToken]
|
lexStream :: P [RlpToken]
|
||||||
lexStream = do
|
lexStream = fmap extract <$> lexStream'
|
||||||
t <- lexToken
|
|
||||||
case t of
|
lexStream' :: P [Located RlpToken]
|
||||||
Located _ TokenEOF -> pure [TokenEOF]
|
lexStream' = lexToken >>= \case
|
||||||
Located _ t -> (t:) <$> lexStream
|
t@(Located _ TokenEOF) -> pure [t]
|
||||||
|
t -> (t:) <$> lexStream'
|
||||||
|
|
||||||
lexDebug :: (Located RlpToken -> P a) -> P a
|
lexDebug :: (Located RlpToken -> P a) -> P a
|
||||||
lexDebug k = do
|
lexDebug k = do
|
||||||
|
|||||||
252
src/Rlp/Parse.y
252
src/Rlp/Parse.y
@@ -5,15 +5,17 @@ module Rlp.Parse
|
|||||||
, parseRlpProgR
|
, parseRlpProgR
|
||||||
, parseRlpExpr
|
, parseRlpExpr
|
||||||
, parseRlpExprR
|
, parseRlpExprR
|
||||||
|
, runP'
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Compiler.RlpcError
|
import Compiler.RlpcError
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
|
import Control.Comonad.Cofree
|
||||||
import Rlp.Lex
|
import Rlp.Lex
|
||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
import Rlp.Parse.Associate
|
import Rlp.Parse.Associate
|
||||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~))
|
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.Fix
|
import Data.Fix
|
||||||
import Data.Functor.Const
|
import Data.Functor.Const
|
||||||
@@ -71,12 +73,11 @@ import Compiler.Types
|
|||||||
|
|
||||||
%%
|
%%
|
||||||
|
|
||||||
StandaloneProgram :: { RlpProgram RlpcPs }
|
StandaloneProgram :: { Program RlpcPs SrcSpan }
|
||||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
|
||||||
| VL DeclsV VR {% mkProgram $2 }
|
|
||||||
|
|
||||||
StandaloneExpr :: { RlpExpr RlpcPs }
|
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
||||||
: VL Expr VR { extract $2 }
|
: VL Expr VR { $2 }
|
||||||
|
|
||||||
VL :: { () }
|
VL :: { () }
|
||||||
VL : vlbrace { () }
|
VL : vlbrace { () }
|
||||||
@@ -85,125 +86,105 @@ VR :: { () }
|
|||||||
VR : vrbrace { () }
|
VR : vrbrace { () }
|
||||||
| error { () }
|
| error { () }
|
||||||
|
|
||||||
Decls :: { [Decl' RlpcPs] }
|
VS :: { () }
|
||||||
Decls : Decl ';' Decls { $1 : $3 }
|
VS : ';' { () }
|
||||||
| Decl ';' { [$1] }
|
| vsemi { () }
|
||||||
| Decl { [$1] }
|
|
||||||
|
|
||||||
DeclsV :: { [Decl' RlpcPs] }
|
Decl :: { Decl RlpcPs SrcSpan }
|
||||||
DeclsV : Decl VS DeclsV { $1 : $3 }
|
|
||||||
| Decl VS { [$1] }
|
|
||||||
| Decl { [$1] }
|
|
||||||
|
|
||||||
VS :: { Located RlpToken }
|
|
||||||
VS : ';' { $1 }
|
|
||||||
| vsemi { $1 }
|
|
||||||
|
|
||||||
Decl :: { Decl' RlpcPs }
|
|
||||||
: FunDecl { $1 }
|
: FunDecl { $1 }
|
||||||
| TySigDecl { $1 }
|
| TySigDecl { $1 }
|
||||||
| DataDecl { $1 }
|
| DataDecl { $1 }
|
||||||
| InfixDecl { $1 }
|
| InfixDecl { $1 }
|
||||||
|
|
||||||
TySigDecl :: { Decl' RlpcPs }
|
TySigDecl :: { Decl RlpcPs SrcSpan }
|
||||||
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
|
: Var '::' Type { TySigD [$1] $3 }
|
||||||
|
|
||||||
InfixDecl :: { Decl' RlpcPs }
|
InfixDecl :: { Decl RlpcPs SrcSpan }
|
||||||
: InfixWord litint InfixOp { $1 =>> \w ->
|
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
|
||||||
InfixD (extract $1) (extractInt $ extract $2)
|
|
||||||
(extract $3) }
|
|
||||||
|
|
||||||
InfixWord :: { Located Assoc }
|
InfixWord :: { Assoc }
|
||||||
: infixl { $1 \$> InfixL }
|
: infixl { InfixL }
|
||||||
| infixr { $1 \$> InfixR }
|
| infixr { InfixR }
|
||||||
| infix { $1 \$> Infix }
|
| infix { Infix }
|
||||||
|
|
||||||
DataDecl :: { Decl' RlpcPs }
|
DataDecl :: { Decl RlpcPs SrcSpan }
|
||||||
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
|
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||||
|
|
||||||
TyParams :: { [PsName] }
|
TyParams :: { [PsName] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
|
| TyParams varname { $1 `snoc` extractName $2 }
|
||||||
|
|
||||||
DataCons :: { [ConAlt RlpcPs] }
|
DataCons :: { [ConAlt RlpcPs] }
|
||||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||||
| DataCon { [$1] }
|
| DataCon { [$1] }
|
||||||
|
|
||||||
DataCon :: { ConAlt RlpcPs }
|
DataCon :: { ConAlt RlpcPs }
|
||||||
: Con Type1s { ConAlt (extract $1) $2 }
|
: Con Type1s { ConAlt $1 $2 }
|
||||||
|
|
||||||
Type1s :: { [RlpType' RlpcPs] }
|
Type1s :: { [Ty RlpcPs] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| Type1s Type1 { $1 `snoc` $2 }
|
| Type1s Type1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Type1 :: { RlpType' RlpcPs }
|
Type1 :: { Ty RlpcPs }
|
||||||
: '(' Type ')' { $2 }
|
: '(' Type ')' { $2 }
|
||||||
| conname { fmap ConT (mkPsName $1) }
|
| conname { ConT (extractName $1) }
|
||||||
| varname { fmap VarT (mkPsName $1) }
|
| varname { VarT (extractName $1) }
|
||||||
|
|
||||||
Type :: { RlpType' RlpcPs }
|
Type :: { Ty RlpcPs }
|
||||||
: Type '->' Type { FunT <<~ $1 <~> $3 }
|
: Type '->' Type { FunT $1 $3 }
|
||||||
| TypeApp { $1 }
|
| TypeApp { $1 }
|
||||||
|
|
||||||
TypeApp :: { RlpType' RlpcPs }
|
TypeApp :: { Ty RlpcPs }
|
||||||
: Type1 { $1 }
|
: Type1 { $1 }
|
||||||
| TypeApp Type1 { AppT <<~ $1 <~> $2 }
|
| TypeApp Type1 { AppT $1 $2 }
|
||||||
|
|
||||||
FunDecl :: { Decl' RlpcPs }
|
FunDecl :: { Decl RlpcPs SrcSpan }
|
||||||
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||||||
FunD (extract $1) $2 e Nothing }
|
|
||||||
|
|
||||||
Params :: { [Pat' RlpcPs] }
|
Params :: { [Pat RlpcPs] }
|
||||||
Params : {- epsilon -} { [] }
|
Params : {- epsilon -} { [] }
|
||||||
| Params Pat1 { $1 `snoc` $2 }
|
| Params Pat1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Pat :: { Pat' RlpcPs }
|
Pat :: { Pat RlpcPs }
|
||||||
: Con Pat1s { $1 =>> \cn ->
|
: Con Pat1s { ConP $1 $2 }
|
||||||
ConP (extract $1) $2 }
|
|
||||||
| Pat1 { $1 }
|
| Pat1 { $1 }
|
||||||
|
|
||||||
Pat1s :: { [Pat' RlpcPs] }
|
Pat1s :: { [Pat RlpcPs] }
|
||||||
: Pat1s Pat1 { $1 `snoc` $2 }
|
: Pat1s Pat1 { $1 `snoc` $2 }
|
||||||
| Pat1 { [$1] }
|
| Pat1 { [$1] }
|
||||||
|
|
||||||
Pat1 :: { Pat' RlpcPs }
|
Pat1 :: { Pat RlpcPs }
|
||||||
: Con { fmap (`ConP` []) $1 }
|
: Con { ConP $1 [] }
|
||||||
| Var { fmap VarP $1 }
|
| Var { VarP $1 }
|
||||||
| Lit { LitP <<= $1 }
|
| Lit { LitP $1 }
|
||||||
| '(' Pat ')' { $1 .> $2 <. $3 }
|
| '(' Pat ')' { $2 }
|
||||||
|
|
||||||
Expr :: { RlpExpr' RlpcPs }
|
Expr :: { Expr' RlpcPs SrcSpan }
|
||||||
-- infixities delayed till next release :(
|
-- infixities delayed till next release :(
|
||||||
-- : Expr1 InfixOp Expr { $2 =>> \o ->
|
-- : Expr1 InfixOp Expr { undefined }
|
||||||
-- OAppE (extract o) $1 $3 }
|
: AppExpr { $1 }
|
||||||
: TempInfixExpr { $1 }
|
| TempInfixExpr { $1 }
|
||||||
| LetExpr { $1 }
|
| LetExpr { $1 }
|
||||||
| CaseExpr { $1 }
|
| CaseExpr { $1 }
|
||||||
| AppExpr { $1 }
|
|
||||||
|
|
||||||
TempInfixExpr :: { RlpExpr' RlpcPs }
|
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
||||||
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
||||||
| Expr1 InfixOp Expr1 { $2 =>> \o ->
|
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
|
||||||
OAppE (extract o) $1 $3 }
|
|
||||||
|
|
||||||
AppExpr :: { RlpExpr' RlpcPs }
|
AppExpr :: { Expr' RlpcPs SrcSpan }
|
||||||
: Expr1 { $1 }
|
: Expr1 { $1 }
|
||||||
| AppExpr Expr1 { AppE <<~ $1 <~> $2 }
|
| AppExpr Expr1 { comb2 AppEF $1 $2 }
|
||||||
|
|
||||||
LetExpr :: { RlpExpr' RlpcPs }
|
LetExpr :: { Expr' RlpcPs SrcSpan }
|
||||||
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
|
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
|
||||||
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 }
|
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
|
||||||
|
|
||||||
CaseExpr :: { RlpExpr' RlpcPs }
|
CaseExpr :: { Expr' RlpcPs SrcSpan }
|
||||||
: case Expr of layout0(CaseAlt)
|
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
|
||||||
{ CaseE <<~ $2 <#> $4 }
|
|
||||||
|
|
||||||
-- TODO: where-binds
|
-- TODO: where-binds
|
||||||
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
|
Alt :: { Alt' RlpcPs SrcSpan }
|
||||||
: Alt { ($1, []) }
|
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
|
||||||
|
|
||||||
Alt :: { Alt RlpcPs }
|
|
||||||
: Pat '->' Expr { AltA $1 $3 }
|
|
||||||
|
|
||||||
-- layout0(p : β) :: [β]
|
-- layout0(p : β) :: [β]
|
||||||
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
||||||
@@ -222,38 +203,68 @@ layout1(p) : '{' layout_list1(';',p) '}' { $2 }
|
|||||||
layout_list1(sep,p) : p { [$1] }
|
layout_list1(sep,p) : p { [$1] }
|
||||||
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
||||||
|
|
||||||
Binding :: { Binding' RlpcPs }
|
Binding :: { Binding' RlpcPs SrcSpan }
|
||||||
: Pat '=' Expr { PatB <<~ $1 <~> $3 }
|
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
|
||||||
|
|
||||||
Expr1 :: { RlpExpr' RlpcPs }
|
Expr1 :: { Expr' RlpcPs SrcSpan }
|
||||||
: '(' Expr ')' { $1 .> $2 <. $3 }
|
: '(' Expr ')' { $2 }
|
||||||
| Lit { fmap LitE $1 }
|
| Lit { nolo' $ LitEF $1 }
|
||||||
| Var { fmap VarE $1 }
|
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||||
| Con { fmap VarE $1 }
|
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||||
|
|
||||||
InfixOp :: { Located PsName }
|
InfixOp :: { PsName }
|
||||||
: consym { mkPsName $1 }
|
: consym { extractName $1 }
|
||||||
| varsym { mkPsName $1 }
|
| varsym { extractName $1 }
|
||||||
|
|
||||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||||
Lit :: { Lit' RlpcPs }
|
Lit :: { Lit RlpcPs }
|
||||||
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
: litint { $1 ^. to extract
|
||||||
|
. singular _TokenLitInt
|
||||||
|
. to IntL }
|
||||||
|
|
||||||
Var :: { Located PsName }
|
Var :: { PsName }
|
||||||
Var : varname { mkPsName $1 }
|
Var : varname { $1 <&> view (singular _TokenVarName) }
|
||||||
| varsym { mkPsName $1 }
|
| varsym { $1 <&> view (singular _TokenVarSym) }
|
||||||
|
|
||||||
Con :: { Located PsName }
|
Con :: { PsName }
|
||||||
: conname { mkPsName $1 }
|
: conname { $1 <&> view (singular _TokenConName) }
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
||||||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
|
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
|
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||||||
where
|
where
|
||||||
st = programInitState s
|
st = programInitState s
|
||||||
|
|
||||||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
|
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
|
parseRlpProgR s = do
|
||||||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||||||
addDebugMsg @_ @String "dump-parsed" $ show a
|
addDebugMsg @_ @String "dump-parsed" $ show a
|
||||||
@@ -276,37 +287,48 @@ extractInt :: RlpToken -> Int
|
|||||||
extractInt (TokenLitInt n) = n
|
extractInt (TokenLitInt n) = n
|
||||||
extractInt _ = error "extractInt: ugh"
|
extractInt _ = error "extractInt: ugh"
|
||||||
|
|
||||||
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||||||
mkProgram ds = do
|
mkProgram ds = do
|
||||||
pt <- use psOpTable
|
pt <- use psOpTable
|
||||||
pure $ RlpProgram (associate pt <$> ds)
|
pure $ Program (associate pt <$> ds)
|
||||||
|
|
||||||
parseError :: (Located RlpToken, [String]) -> P a
|
|
||||||
parseError ((Located ss t), exp) = addFatal $
|
|
||||||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
|
||||||
|
|
||||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
|
|
||||||
mkInfixD a p n = do
|
|
||||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
|
||||||
opl = psOpTable . at n
|
|
||||||
opl <~ (use opl >>= \case
|
|
||||||
Just o -> addWoundHere l e >> pure (Just o) where
|
|
||||||
e = RlpParErrDuplicateInfixD n
|
|
||||||
l = T.length n
|
|
||||||
Nothing -> pure (Just (a,p))
|
|
||||||
)
|
|
||||||
pos <- use (psInput . aiPos)
|
|
||||||
pure $ Located (spanFromPos pos 0) (InfixD a p n)
|
|
||||||
|
|
||||||
intOfToken :: Located RlpToken -> Int
|
intOfToken :: Located RlpToken -> Int
|
||||||
intOfToken (Located _ (TokenLitInt n)) = n
|
intOfToken (Located _ (TokenLitInt n)) = n
|
||||||
|
|
||||||
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
|
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
|
||||||
tempInfixExprErr (Located a _) (Located b _) =
|
tempInfixExprErr (Located a _) (Located b _) =
|
||||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||||
, "In the mean time, don't mix any infix operators."
|
, "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)
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -16,7 +16,7 @@ import Rlp.Parse.Types
|
|||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
|
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
|
||||||
associate _ p = p
|
associate _ p = p
|
||||||
|
|
||||||
{-# WARNING associate "unimplemented" #-}
|
{-# WARNING associate "unimplemented" #-}
|
||||||
|
|||||||
@@ -1,6 +1,7 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
module Rlp.Parse.Types
|
module Rlp.Parse.Types
|
||||||
(
|
(
|
||||||
-- * Trees That Grow
|
-- * Trees That Grow
|
||||||
@@ -17,10 +18,9 @@ module Rlp.Parse.Types
|
|||||||
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
||||||
, Located(..), PsName
|
, Located(..), PsName
|
||||||
-- ** Lenses
|
-- ** Lenses
|
||||||
|
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
|
||||||
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
||||||
|
|
||||||
, (<<~), (<~>)
|
|
||||||
|
|
||||||
-- * Error handling
|
-- * Error handling
|
||||||
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
||||||
, addFatal, addWound, addFatalHere, addWoundHere
|
, addFatal, addWound, addFatalHere, addWoundHere
|
||||||
@@ -28,6 +28,7 @@ module Rlp.Parse.Types
|
|||||||
where
|
where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Core.Syntax (Name)
|
import Core.Syntax (Name)
|
||||||
|
import Text.Show.Deriving
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Control.Monad.Errorful
|
import Control.Monad.Errorful
|
||||||
@@ -53,34 +54,9 @@ import Compiler.Types
|
|||||||
|
|
||||||
data RlpcPs
|
data RlpcPs
|
||||||
|
|
||||||
type instance XRec RlpcPs a = Located a
|
type instance NameP RlpcPs = PsName
|
||||||
type instance IdP RlpcPs = PsName
|
|
||||||
|
|
||||||
type instance XFunD RlpcPs = ()
|
type PsName = Located Text
|
||||||
type instance XDataD RlpcPs = ()
|
|
||||||
type instance XInfixD RlpcPs = ()
|
|
||||||
type instance XTySigD RlpcPs = ()
|
|
||||||
type instance XXDeclD RlpcPs = ()
|
|
||||||
|
|
||||||
type instance XLetE RlpcPs = ()
|
|
||||||
type instance XLetrecE RlpcPs = ()
|
|
||||||
type instance XVarE RlpcPs = ()
|
|
||||||
type instance XLamE RlpcPs = ()
|
|
||||||
type instance XCaseE RlpcPs = ()
|
|
||||||
type instance XIfE RlpcPs = ()
|
|
||||||
type instance XAppE RlpcPs = ()
|
|
||||||
type instance XLitE RlpcPs = ()
|
|
||||||
type instance XParE RlpcPs = ()
|
|
||||||
type instance XOAppE RlpcPs = ()
|
|
||||||
type instance XXRlpExprE RlpcPs = ()
|
|
||||||
|
|
||||||
type PsName = Text
|
|
||||||
|
|
||||||
instance MapXRec RlpcPs where
|
|
||||||
mapXRec = fmap
|
|
||||||
|
|
||||||
instance UnXRec RlpcPs where
|
|
||||||
unXRec = extract
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
@@ -118,10 +94,10 @@ data RlpToken
|
|||||||
-- literals
|
-- literals
|
||||||
= TokenLitInt Int
|
= TokenLitInt Int
|
||||||
-- identifiers
|
-- identifiers
|
||||||
| TokenVarName Name
|
| TokenVarName Text
|
||||||
| TokenConName Name
|
| TokenConName Text
|
||||||
| TokenVarSym Name
|
| TokenVarSym Text
|
||||||
| TokenConSym Name
|
| TokenConSym Text
|
||||||
-- reserved words
|
-- reserved words
|
||||||
| TokenData
|
| TokenData
|
||||||
| TokenCase
|
| TokenCase
|
||||||
@@ -152,6 +128,31 @@ data RlpToken
|
|||||||
| TokenEOF
|
| TokenEOF
|
||||||
deriving (Show)
|
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 {
|
newtype P a = P {
|
||||||
runP :: ParseState
|
runP :: ParseState
|
||||||
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||||
@@ -281,13 +282,14 @@ initAlexInput s = AlexInput
|
|||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
deriving instance Lift (RlpProgram RlpcPs)
|
|
||||||
deriving instance Lift (Decl RlpcPs)
|
-- deriving instance Lift (Program RlpcPs)
|
||||||
deriving instance Lift (Pat RlpcPs)
|
-- deriving instance Lift (Decl RlpcPs)
|
||||||
deriving instance Lift (Lit RlpcPs)
|
-- deriving instance Lift (Pat RlpcPs)
|
||||||
deriving instance Lift (RlpExpr RlpcPs)
|
-- deriving instance Lift (Lit RlpcPs)
|
||||||
deriving instance Lift (Binding RlpcPs)
|
-- deriving instance Lift (Expr RlpcPs)
|
||||||
deriving instance Lift (RlpType RlpcPs)
|
-- deriving instance Lift (Binding RlpcPs)
|
||||||
deriving instance Lift (Alt RlpcPs)
|
-- deriving instance Lift (Ty RlpcPs)
|
||||||
deriving instance Lift (ConAlt RlpcPs)
|
-- deriving instance Lift (Alt RlpcPs)
|
||||||
|
-- deriving instance Lift (ConAlt RlpcPs)
|
||||||
|
|
||||||
|
|||||||
@@ -1,362 +1,10 @@
|
|||||||
-- recursion-schemes
|
|
||||||
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
|
|
||||||
, TemplateHaskell, TypeFamilies #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
|
|
||||||
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
|
|
||||||
module Rlp.Syntax
|
module Rlp.Syntax
|
||||||
(
|
( module Rlp.Syntax.Backstage
|
||||||
-- * AST
|
, module Rlp.Syntax.Types
|
||||||
RlpProgram(..)
|
|
||||||
, progDecls
|
|
||||||
, Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
|
|
||||||
, Pat(..), Pat'
|
|
||||||
, Alt(..), Where
|
|
||||||
, Assoc(..)
|
|
||||||
, Lit(..), Lit'
|
|
||||||
, RlpType(..), RlpType'
|
|
||||||
, ConAlt(..)
|
|
||||||
, Binding(..), Binding'
|
|
||||||
|
|
||||||
, _PatB, _FunB
|
|
||||||
, _VarP, _LitP, _ConP
|
|
||||||
|
|
||||||
-- * Trees That Grow boilerplate
|
|
||||||
-- ** Extension points
|
|
||||||
, IdP, IdP', XRec, UnXRec(..), MapXRec(..)
|
|
||||||
-- *** Decl
|
|
||||||
, XFunD, XTySigD, XInfixD, XDataD, XXDeclD
|
|
||||||
-- *** RlpExpr
|
|
||||||
, XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
|
|
||||||
, XParE, XOAppE, XXRlpExprE
|
|
||||||
-- ** Pattern synonyms
|
|
||||||
-- *** Decl
|
|
||||||
, pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
|
|
||||||
, pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
|
|
||||||
-- *** RlpExpr
|
|
||||||
, pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
|
|
||||||
, pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
|
|
||||||
, pattern XRlpExprE
|
|
||||||
-- *** RlpType
|
|
||||||
, pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
|
|
||||||
, pattern ConT''
|
|
||||||
-- *** Pat
|
|
||||||
, pattern VarP'', pattern LitP'', pattern ConP''
|
|
||||||
-- *** Binding
|
|
||||||
, pattern PatB''
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Data.Text (Text)
|
import Rlp.Syntax.Backstage
|
||||||
import Data.Text qualified as T
|
import Rlp.Syntax.Types
|
||||||
import Data.String (IsString(..))
|
|
||||||
import Data.Functor.Foldable
|
|
||||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
|
||||||
import Data.Functor.Classes
|
|
||||||
import Data.Functor.Identity
|
|
||||||
import Data.Kind (Type)
|
|
||||||
import GHC.Generics
|
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
|
||||||
import Control.Lens
|
|
||||||
import Core.Syntax hiding (Lit, Type, Binding, Binding')
|
|
||||||
import Core (HasRHS(..), HasLHS(..))
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
data RlpModule p = RlpModule
|
|
||||||
{ _rlpmodName :: Text
|
|
||||||
, _rlpmodProgram :: RlpProgram p
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | dear god.
|
|
||||||
type PhaseShow p =
|
|
||||||
( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p))
|
|
||||||
, Show (XRec p (Lit p)), Show (IdP p)
|
|
||||||
, Show (XRec p (RlpType p))
|
|
||||||
, Show (XRec p (Binding p))
|
|
||||||
)
|
|
||||||
|
|
||||||
newtype RlpProgram p = RlpProgram [Decl' p]
|
|
||||||
|
|
||||||
progDecls :: Lens' (RlpProgram p) [Decl' p]
|
|
||||||
progDecls = lens
|
|
||||||
(\ (RlpProgram ds) -> ds)
|
|
||||||
(const RlpProgram)
|
|
||||||
|
|
||||||
deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p)
|
|
||||||
|
|
||||||
data RlpType p = FunConT
|
|
||||||
| FunT (RlpType' p) (RlpType' p)
|
|
||||||
| AppT (RlpType' p) (RlpType' p)
|
|
||||||
| VarT (IdP p)
|
|
||||||
| ConT (IdP p)
|
|
||||||
|
|
||||||
type RlpType' p = XRec p (RlpType p)
|
|
||||||
|
|
||||||
pattern FunConT'' :: (UnXRec p) => RlpType' p
|
|
||||||
pattern FunT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
|
|
||||||
pattern AppT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
|
|
||||||
pattern VarT'' :: (UnXRec p) => IdP p -> RlpType' p
|
|
||||||
pattern ConT'' :: (UnXRec p) => IdP p -> RlpType' p
|
|
||||||
|
|
||||||
pattern FunConT'' <- (unXRec -> FunConT)
|
|
||||||
pattern FunT'' s t <- (unXRec -> FunT s t)
|
|
||||||
pattern AppT'' s t <- (unXRec -> AppT s t)
|
|
||||||
pattern VarT'' n <- (unXRec -> VarT n)
|
|
||||||
pattern ConT'' n <- (unXRec -> ConT n)
|
|
||||||
|
|
||||||
deriving instance (PhaseShow p)
|
|
||||||
=> Show (RlpType p)
|
|
||||||
|
|
||||||
data Decl p = FunD' (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
|
|
||||||
| TySigD' (XTySigD p) [IdP p] (RlpType' p)
|
|
||||||
| DataD' (XDataD p) (IdP p) [IdP p] [ConAlt p]
|
|
||||||
| InfixD' (XInfixD p) Assoc Int (IdP p)
|
|
||||||
| XDeclD' !(XXDeclD p)
|
|
||||||
|
|
||||||
deriving instance
|
|
||||||
( Show (XFunD p), Show (XTySigD p)
|
|
||||||
, Show (XDataD p), Show (XInfixD p)
|
|
||||||
, Show (XXDeclD p)
|
|
||||||
, PhaseShow p
|
|
||||||
)
|
|
||||||
=> Show (Decl p)
|
|
||||||
|
|
||||||
type family XFunD p
|
|
||||||
type family XTySigD p
|
|
||||||
type family XDataD p
|
|
||||||
type family XInfixD p
|
|
||||||
type family XXDeclD p
|
|
||||||
|
|
||||||
pattern FunD :: (XFunD p ~ ())
|
|
||||||
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
|
|
||||||
-> Decl p
|
|
||||||
pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p
|
|
||||||
pattern DataD :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
|
|
||||||
pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p
|
|
||||||
pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
|
|
||||||
|
|
||||||
pattern FunD n as e wh = FunD' () n as e wh
|
|
||||||
pattern TySigD ns t = TySigD' () ns t
|
|
||||||
pattern DataD n as cs = DataD' () n as cs
|
|
||||||
pattern InfixD a p n = InfixD' () a p n
|
|
||||||
pattern XDeclD = XDeclD' ()
|
|
||||||
|
|
||||||
pattern FunD'' :: (UnXRec p)
|
|
||||||
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
|
|
||||||
-> Decl' p
|
|
||||||
pattern TySigD'' :: (UnXRec p)
|
|
||||||
=> [IdP p] -> RlpType' p -> Decl' p
|
|
||||||
pattern DataD'' :: (UnXRec p)
|
|
||||||
=> IdP p -> [IdP p] -> [ConAlt p] -> Decl' p
|
|
||||||
pattern InfixD'' :: (UnXRec p)
|
|
||||||
=> Assoc -> Int -> IdP p -> Decl' p
|
|
||||||
|
|
||||||
pattern FunD'' n as e wh <- (unXRec -> FunD' _ n as e wh)
|
|
||||||
pattern TySigD'' ns t <- (unXRec -> TySigD' _ ns t)
|
|
||||||
pattern DataD'' n as ds <- (unXRec -> DataD' _ n as ds)
|
|
||||||
pattern InfixD'' a p n <- (unXRec -> InfixD' _ a p n)
|
|
||||||
|
|
||||||
type Decl' p = XRec p (Decl p)
|
|
||||||
|
|
||||||
data Assoc = InfixL
|
|
||||||
| InfixR
|
|
||||||
| Infix
|
|
||||||
deriving (Show, Lift)
|
|
||||||
|
|
||||||
data ConAlt p = ConAlt (IdP p) [RlpType' p]
|
|
||||||
|
|
||||||
deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
|
|
||||||
|
|
||||||
data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p)
|
|
||||||
| LetrecE' (XLetrecE p) [Binding' p] (RlpExpr' p)
|
|
||||||
| VarE' (XVarE p) (IdP p)
|
|
||||||
| LamE' (XLamE p) [Pat p] (RlpExpr' p)
|
|
||||||
| CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
|
|
||||||
| IfE' (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
|
|
||||||
| AppE' (XAppE p) (RlpExpr' p) (RlpExpr' p)
|
|
||||||
| LitE' (XLitE p) (Lit p)
|
|
||||||
| ParE' (XParE p) (RlpExpr' p)
|
|
||||||
| OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
|
|
||||||
| XRlpExprE' !(XXRlpExprE p)
|
|
||||||
deriving (Generic)
|
|
||||||
|
|
||||||
type family XLetE p
|
|
||||||
type family XLetrecE p
|
|
||||||
type family XVarE p
|
|
||||||
type family XLamE p
|
|
||||||
type family XCaseE p
|
|
||||||
type family XIfE p
|
|
||||||
type family XAppE p
|
|
||||||
type family XLitE p
|
|
||||||
type family XParE p
|
|
||||||
type family XOAppE p
|
|
||||||
type family XXRlpExprE p
|
|
||||||
|
|
||||||
pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
|
|
||||||
pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
|
|
||||||
pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
|
|
||||||
pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
|
|
||||||
pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
|
||||||
pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
|
|
||||||
|
|
||||||
pattern LetE bs e = LetE' () bs e
|
|
||||||
pattern LetrecE bs e = LetrecE' () bs e
|
|
||||||
pattern VarE n = VarE' () n
|
|
||||||
pattern LamE as e = LamE' () as e
|
|
||||||
pattern CaseE e as = CaseE' () e as
|
|
||||||
pattern IfE c a b = IfE' () c a b
|
|
||||||
pattern AppE f x = AppE' () f x
|
|
||||||
pattern LitE l = LitE' () l
|
|
||||||
pattern ParE e = ParE' () e
|
|
||||||
pattern OAppE n a b = OAppE' () n a b
|
|
||||||
pattern XRlpExprE = XRlpExprE' ()
|
|
||||||
|
|
||||||
deriving instance
|
|
||||||
( Show (XLetE p), Show (XLetrecE p), Show (XVarE p)
|
|
||||||
, Show (XLamE p), Show (XCaseE p), Show (XIfE p)
|
|
||||||
, Show (XAppE p), Show (XLitE p), Show (XParE p)
|
|
||||||
, Show (XOAppE p), Show (XXRlpExprE p)
|
|
||||||
, PhaseShow p
|
|
||||||
) => Show (RlpExpr p)
|
|
||||||
|
|
||||||
type RlpExpr' p = XRec p (RlpExpr p)
|
|
||||||
|
|
||||||
class UnXRec p where
|
|
||||||
unXRec :: XRec p a -> a
|
|
||||||
|
|
||||||
class WrapXRec p where
|
|
||||||
wrapXRec :: a -> XRec p a
|
|
||||||
|
|
||||||
class MapXRec p where
|
|
||||||
mapXRec :: (a -> b) -> XRec p a -> XRec p b
|
|
||||||
|
|
||||||
-- old definition:
|
|
||||||
-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
|
|
||||||
type family XRec p a = (r :: Type) | r -> p a
|
|
||||||
|
|
||||||
type family IdP p
|
|
||||||
|
|
||||||
type IdP' p = XRec p (IdP p)
|
|
||||||
|
|
||||||
type Where p = [Binding p]
|
|
||||||
|
|
||||||
-- do we want guards?
|
|
||||||
data Alt p = AltA (Pat' p) (RlpExpr' p)
|
|
||||||
|
|
||||||
deriving instance (PhaseShow p) => Show (Alt p)
|
|
||||||
|
|
||||||
data Binding p = PatB (Pat' p) (RlpExpr' p)
|
|
||||||
| FunB (IdP p) [Pat' p] (RlpExpr' p)
|
|
||||||
|
|
||||||
type Binding' p = XRec p (Binding p)
|
|
||||||
|
|
||||||
pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
|
|
||||||
pattern PatB'' p e <- (unXRec -> PatB p e)
|
|
||||||
|
|
||||||
deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
|
|
||||||
) => Show (Binding p)
|
|
||||||
|
|
||||||
data Pat p = VarP (IdP p)
|
|
||||||
| LitP (Lit' p)
|
|
||||||
| ConP (IdP p) [Pat' p]
|
|
||||||
|
|
||||||
pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
|
|
||||||
pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
|
|
||||||
pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
|
|
||||||
|
|
||||||
pattern VarP'' n <- (unXRec -> VarP n)
|
|
||||||
pattern LitP'' l <- (unXRec -> LitP l)
|
|
||||||
pattern ConP'' c as <- (unXRec -> ConP c as)
|
|
||||||
|
|
||||||
deriving instance (PhaseShow p) => Show (Pat p)
|
|
||||||
|
|
||||||
type Pat' p = XRec p (Pat p)
|
|
||||||
|
|
||||||
data Lit p = IntL Int
|
|
||||||
| CharL Char
|
|
||||||
| ListL [RlpExpr' p]
|
|
||||||
|
|
||||||
deriving instance (PhaseShow p) => Show (Lit p)
|
|
||||||
|
|
||||||
type Lit' p = XRec p (Lit p)
|
|
||||||
|
|
||||||
-- instance HasLHS Alt Alt Pat Pat where
|
|
||||||
-- _lhs = lens
|
|
||||||
-- (\ (AltA p _) -> p)
|
|
||||||
-- (\ (AltA _ e) p' -> AltA p' e)
|
|
||||||
|
|
||||||
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
|
|
||||||
-- _rhs = lens
|
|
||||||
-- (\ (AltA _ e) -> e)
|
|
||||||
-- (\ (AltA p _) e' -> AltA p e')
|
|
||||||
|
|
||||||
-- makeBaseFunctor ''RlpExpr
|
|
||||||
|
|
||||||
-- showsTernaryWith :: (Int -> x -> ShowS)
|
|
||||||
-- -> (Int -> y -> ShowS)
|
|
||||||
-- -> (Int -> z -> ShowS)
|
|
||||||
-- -> String -> Int
|
|
||||||
-- -> x -> y -> z
|
|
||||||
-- -> ShowS
|
|
||||||
-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
|
|
||||||
-- $ showString name
|
|
||||||
-- . showChar ' ' . sa 11 a
|
|
||||||
-- . showChar ' ' . sb 11 b
|
|
||||||
-- . showChar ' ' . sc 11 c
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
makeLenses ''RlpModule
|
|
||||||
makePrisms ''Pat
|
|
||||||
makePrisms ''Binding
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
data RlpExprF p a = LetE'F (XLetE p) [Binding' p] a
|
|
||||||
| LetrecE'F (XLetrecE p) [Binding' p] a
|
|
||||||
| VarE'F (XVarE p) (IdP p)
|
|
||||||
| LamE'F (XLamE p) [Pat p] a
|
|
||||||
| CaseE'F (XCaseE p) a [(Alt p, Where p)]
|
|
||||||
| IfE'F (XIfE p) a a a
|
|
||||||
| AppE'F (XAppE p) a a
|
|
||||||
| LitE'F (XLitE p) (Lit p)
|
|
||||||
| ParE'F (XParE p) a
|
|
||||||
| OAppE'F (XOAppE p) (IdP p) a a
|
|
||||||
| XRlpExprE'F !(XXRlpExprE p)
|
|
||||||
deriving (Functor, Foldable, Traversable, Generic)
|
|
||||||
|
|
||||||
type instance Base (RlpExpr p) = RlpExprF p
|
|
||||||
|
|
||||||
instance (UnXRec p) => Recursive (RlpExpr p) where
|
|
||||||
project = \case
|
|
||||||
LetE' xx bs e -> LetE'F xx bs (unXRec e)
|
|
||||||
LetrecE' xx bs e -> LetrecE'F xx bs (unXRec e)
|
|
||||||
VarE' xx n -> VarE'F xx n
|
|
||||||
LamE' xx ps e -> LamE'F xx ps (unXRec e)
|
|
||||||
CaseE' xx e as -> CaseE'F xx (unXRec e) as
|
|
||||||
IfE' xx a b c -> IfE'F xx (unXRec a) (unXRec b) (unXRec c)
|
|
||||||
AppE' xx f x -> AppE'F xx (unXRec f) (unXRec x)
|
|
||||||
LitE' xx l -> LitE'F xx l
|
|
||||||
ParE' xx e -> ParE'F xx (unXRec e)
|
|
||||||
OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b)
|
|
||||||
XRlpExprE' xx -> XRlpExprE'F xx
|
|
||||||
|
|
||||||
instance (WrapXRec p) => Corecursive (RlpExpr p) where
|
|
||||||
embed = \case
|
|
||||||
LetE'F xx bs e -> LetE' xx bs (wrapXRec e)
|
|
||||||
LetrecE'F xx bs e -> LetrecE' xx bs (wrapXRec e)
|
|
||||||
VarE'F xx n -> VarE' xx n
|
|
||||||
LamE'F xx ps e -> LamE' xx ps (wrapXRec e)
|
|
||||||
CaseE'F xx e as -> CaseE' xx (wrapXRec e) as
|
|
||||||
IfE'F xx a b c -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c)
|
|
||||||
AppE'F xx f x -> AppE' xx (wrapXRec f) (wrapXRec x)
|
|
||||||
LitE'F xx l -> LitE' xx l
|
|
||||||
ParE'F xx e -> ParE' xx (wrapXRec e)
|
|
||||||
OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b)
|
|
||||||
XRlpExprE'F xx -> XRlpExprE' xx
|
|
||||||
|
|
||||||
|
|||||||
35
src/Rlp/Syntax/Backstage.hs
Normal file
35
src/Rlp/Syntax/Backstage.hs
Normal file
@@ -0,0 +1,35 @@
|
|||||||
|
{-# 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
|
||||||
|
|
||||||
143
src/Rlp/Syntax/Types.hs
Normal file
143
src/Rlp/Syntax/Types.hs
Normal file
@@ -0,0 +1,143 @@
|
|||||||
|
-- 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(..)
|
||||||
|
, Program(..)
|
||||||
|
, Where
|
||||||
|
|
||||||
|
-- * Re-exports
|
||||||
|
, Cofree(..)
|
||||||
|
, Trans.Cofree.CofreeF
|
||||||
|
, SrcSpan(..)
|
||||||
|
)
|
||||||
|
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
|
||||||
|
|
||||||
@@ -17,10 +17,12 @@ import Rlp.Parse
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
rlpProg :: QuasiQuoter
|
rlpProg :: QuasiQuoter
|
||||||
rlpProg = mkqq parseRlpProgR
|
rlpProg = undefined
|
||||||
|
-- rlpProg = mkqq parseRlpProgR
|
||||||
|
|
||||||
rlpExpr :: QuasiQuoter
|
rlpExpr :: QuasiQuoter
|
||||||
rlpExpr = mkqq parseRlpExprR
|
rlpExpr = undefined
|
||||||
|
-- rlpExpr = mkqq parseRlpExprR
|
||||||
|
|
||||||
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
||||||
mkq parse = evalAndParse >=> lift where
|
mkq parse = evalAndParse >=> lift where
|
||||||
|
|||||||
@@ -41,6 +41,12 @@ import Rlp.Syntax as Rlp
|
|||||||
import Rlp.Parse.Types (RlpcPs, PsName)
|
import Rlp.Parse.Types (RlpcPs, PsName)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
desugarRlpProgR = undefined
|
||||||
|
desugarRlpProg = undefined
|
||||||
|
desugarRlpExpr = undefined
|
||||||
|
|
||||||
|
{--
|
||||||
|
|
||||||
type Tree a = Either Name (Name, Branch a)
|
type Tree a = Either Name (Name, Branch a)
|
||||||
|
|
||||||
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
||||||
@@ -234,3 +240,5 @@ typeToCore (VarT'' x) = TyVar (dsNameToName x)
|
|||||||
dsNameToName :: IdP RlpcPs -> Name
|
dsNameToName :: IdP RlpcPs -> Name
|
||||||
dsNameToName = id
|
dsNameToName = id
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
||||||
|
|||||||
67
tst/Compiler/TypesSpec.hs
Normal file
67
tst/Compiler/TypesSpec.hs
Normal file
@@ -0,0 +1,67 @@
|
|||||||
|
{-# 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
|
||||||
|
]
|
||||||
|
|
||||||
21
visualisers/gmvis/.gitignore
vendored
21
visualisers/gmvis/.gitignore
vendored
@@ -1,21 +0,0 @@
|
|||||||
node_modules/
|
|
||||||
public/js
|
|
||||||
|
|
||||||
/target
|
|
||||||
/checkouts
|
|
||||||
/src/gen
|
|
||||||
|
|
||||||
pom.xml
|
|
||||||
pom.xml.asc
|
|
||||||
*.iml
|
|
||||||
*.jar
|
|
||||||
*.log
|
|
||||||
.shadow-cljs
|
|
||||||
.idea
|
|
||||||
.lein-*
|
|
||||||
.nrepl-*
|
|
||||||
.DS_Store
|
|
||||||
|
|
||||||
.hgignore
|
|
||||||
.hg/
|
|
||||||
|
|
||||||
1362
visualisers/gmvis/package-lock.json
generated
1362
visualisers/gmvis/package-lock.json
generated
File diff suppressed because it is too large
Load Diff
@@ -1 +0,0 @@
|
|||||||
{"name":"gmvis","version":"0.0.1","private":true,"devDependencies":{"shadow-cljs":"2.28.3"},"dependencies":{"ace-builds":"^1.32.7","react":"^18.3.0","react-ace":"11.0.1","react-dom":"18.3.0","react-resplit":"^1.3.1","react-tooltip":"^5.26.3"}}
|
|
||||||
@@ -1,156 +0,0 @@
|
|||||||
@import "solarized-light.css";
|
|
||||||
|
|
||||||
html, body, #mount
|
|
||||||
{ height: 100%
|
|
||||||
; width: 100%
|
|
||||||
}
|
|
||||||
|
|
||||||
body
|
|
||||||
{ max-width: 90%
|
|
||||||
; margin: 0 auto
|
|
||||||
; padding: 0
|
|
||||||
}
|
|
||||||
|
|
||||||
.split-root
|
|
||||||
{ height: 100%
|
|
||||||
}
|
|
||||||
|
|
||||||
.split-splitter
|
|
||||||
{ width: 100%
|
|
||||||
; height: 100%
|
|
||||||
; background: #ccc
|
|
||||||
}
|
|
||||||
|
|
||||||
.split-pane
|
|
||||||
{ margin: 0
|
|
||||||
; padding: 0
|
|
||||||
; overflow: scroll
|
|
||||||
; display: flex
|
|
||||||
; flex-direction: column
|
|
||||||
}
|
|
||||||
|
|
||||||
.pane-content
|
|
||||||
{ margin: 0.5em
|
|
||||||
}
|
|
||||||
|
|
||||||
.view-header
|
|
||||||
{ margin: 0
|
|
||||||
; flex-shrink: 0
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-view
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: column
|
|
||||||
; justify-content: space-between
|
|
||||||
|
|
||||||
/* to fill the container */
|
|
||||||
; flex-grow: 1
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-entry-container
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: column-reverse
|
|
||||||
; align-content: flex-end
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-entry-container.even > .stack-entry:nth-of-type(even)
|
|
||||||
{ background: #0000007f
|
|
||||||
; color: white
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-entry-container.odd > .stack-entry:nth-of-type(odd)
|
|
||||||
{ background: #0000007f
|
|
||||||
; color: white
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-entry
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: row
|
|
||||||
; justify-content: space-between
|
|
||||||
; font-family: monospace;
|
|
||||||
}
|
|
||||||
|
|
||||||
.stack-entry-addr
|
|
||||||
{ align-self: flex-end
|
|
||||||
; opacity: 70%
|
|
||||||
}
|
|
||||||
|
|
||||||
.dump-view
|
|
||||||
{}
|
|
||||||
|
|
||||||
.heap-view
|
|
||||||
{}
|
|
||||||
|
|
||||||
/* .split-pane:has(> .code-view) */
|
|
||||||
/* { overflow: hidden */
|
|
||||||
/* } */
|
|
||||||
|
|
||||||
.code-view
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: column
|
|
||||||
; align-items: stretch
|
|
||||||
; align-content: stretch
|
|
||||||
; justify-content: flex-start
|
|
||||||
; flex-grow: 1
|
|
||||||
}
|
|
||||||
|
|
||||||
.code-view .code-instr-container
|
|
||||||
{ display: grid
|
|
||||||
; overflow: scroll
|
|
||||||
; flex-shrink: 4
|
|
||||||
; min-height: 0
|
|
||||||
}
|
|
||||||
|
|
||||||
.code-view .instr
|
|
||||||
{ font-family: monospace;
|
|
||||||
}
|
|
||||||
|
|
||||||
.code-instr-container.even > .instr:nth-of-type(even)
|
|
||||||
{ background: #0000007f
|
|
||||||
; color: white
|
|
||||||
}
|
|
||||||
|
|
||||||
.code-instr-container.odd > .instr:nth-of-type(odd)
|
|
||||||
{ background: #0000007f
|
|
||||||
; color: white
|
|
||||||
}
|
|
||||||
|
|
||||||
.code-view .code-button-container
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: row
|
|
||||||
/* ; align-self: flex-end */
|
|
||||||
; justify-content: space-between
|
|
||||||
; margin-top: auto
|
|
||||||
; flex-shrink: 0
|
|
||||||
}
|
|
||||||
|
|
||||||
.heap-view
|
|
||||||
{
|
|
||||||
}
|
|
||||||
|
|
||||||
.heap-entry-container
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: column
|
|
||||||
}
|
|
||||||
|
|
||||||
.heap-entry-container > .heap-entry:nth-of-type(even)
|
|
||||||
{ background: #0000007f
|
|
||||||
; color: white
|
|
||||||
}
|
|
||||||
|
|
||||||
.heap-entry
|
|
||||||
{ display: flex
|
|
||||||
; flex-direction: row
|
|
||||||
; justify-content: space-between
|
|
||||||
; font-family: monospace;
|
|
||||||
}
|
|
||||||
|
|
||||||
.heap-entry-addr
|
|
||||||
{ white-space: nowrap
|
|
||||||
}
|
|
||||||
|
|
||||||
/* .heap-entry-container.odd > .heap-entry:nth-of-type(odd) */
|
|
||||||
/* { background: #0000007f */
|
|
||||||
/* ; color: white */
|
|
||||||
/* } */
|
|
||||||
|
|
||||||
@@ -1,304 +0,0 @@
|
|||||||
@import url(http://fonts.googleapis.com/css?family=Inconsolata);
|
|
||||||
@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;
|
|
||||||
width: 100%;
|
|
||||||
}
|
|
||||||
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;
|
|
||||||
}
|
|
||||||
@@ -1,19 +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>The G-Machine</title>
|
|
||||||
|
|
||||||
<style type="text/css" media="screen">
|
|
||||||
</style>
|
|
||||||
</head>
|
|
||||||
<body>
|
|
||||||
<div id="mount">
|
|
||||||
</div>
|
|
||||||
<script src="/js/main.js"></script>
|
|
||||||
</body>
|
|
||||||
</html>
|
|
||||||
|
|
||||||
@@ -1,25 +0,0 @@
|
|||||||
{:source-paths
|
|
||||||
["src"]
|
|
||||||
|
|
||||||
:dependencies
|
|
||||||
[[cider/cider-nrepl "0.24.0"]
|
|
||||||
[nilenso/wscljs "0.2.0"]
|
|
||||||
[org.clojure/core.match "1.1.0"]
|
|
||||||
[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}}}}}
|
|
||||||
|
|
||||||
@@ -1,63 +0,0 @@
|
|||||||
(ns main
|
|
||||||
(:require
|
|
||||||
[ui :as ui]
|
|
||||||
[wscljs.client :as ws]
|
|
||||||
[wscljs.format :as fmt]
|
|
||||||
[clojure.string :as str]
|
|
||||||
[cljs.core.match :refer-macros [match]]
|
|
||||||
[reagent.dom :as rdom]))
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(def *rlp-socket nil)
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn on-message [e]
|
|
||||||
(let [r (js->clj (js/JSON.parse (.-data e)) :keywordize-keys true)]
|
|
||||||
(match r
|
|
||||||
{:tag "Evaluated" :contents c}
|
|
||||||
(reset! ui/current-evaluation c)
|
|
||||||
:else
|
|
||||||
(js/console.warn "unrecognised response from rlp"))))
|
|
||||||
|
|
||||||
(defn send [msg]
|
|
||||||
(ws/send *rlp-socket msg fmt/json))
|
|
||||||
|
|
||||||
(defn on-open []
|
|
||||||
(println "socket opened")
|
|
||||||
(send {:command "evaluate"
|
|
||||||
:source (str/join "\n"
|
|
||||||
["fac n = case (==#) n 0 of"
|
|
||||||
" { <1> -> 1"
|
|
||||||
" ; <0> -> *# n (fac (-# n 1))"
|
|
||||||
" };"
|
|
||||||
""
|
|
||||||
"main = fac 3;"])}))
|
|
||||||
|
|
||||||
(defn init-rlp-socket []
|
|
||||||
(set! *rlp-socket (ws/create "ws://127.0.0.1:9002"
|
|
||||||
{:on-message on-message
|
|
||||||
:on-open on-open
|
|
||||||
:on-close #(println "socket closed")
|
|
||||||
:on-error #(println "error: " %)})))
|
|
||||||
|
|
||||||
;; this is called before any code is reloaded
|
|
||||||
(defn ^:dev/before-load stop []
|
|
||||||
(ws/close *rlp-socket)
|
|
||||||
(js/console.log "stop"))
|
|
||||||
|
|
||||||
;; start is called by init and after code reloading finishes
|
|
||||||
(defn ^:dev/after-load start []
|
|
||||||
(js/console.log "start")
|
|
||||||
(rdom/render [ui/Main]
|
|
||||||
(js/document.getElementById "mount"))
|
|
||||||
(init-rlp-socket))
|
|
||||||
|
|
||||||
;; 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
|
|
||||||
(defn init []
|
|
||||||
(js/console.log "init")
|
|
||||||
(start))
|
|
||||||
|
|
||||||
@@ -1,230 +0,0 @@
|
|||||||
(ns ui
|
|
||||||
(:require
|
|
||||||
[clojure.pprint :refer (cl-format)]
|
|
||||||
[wscljs.client :as ws]
|
|
||||||
[wscljs.format :as fmt]
|
|
||||||
[clojure.string :as str]
|
|
||||||
[cljs.core.match :refer-macros [match]]
|
|
||||||
["react-ace$default" :as AceEditor]
|
|
||||||
["react-resplit" :refer (Resplit)]
|
|
||||||
["ace-builds/src-noconflict/mode-haskell"]
|
|
||||||
["ace-builds/src-noconflict/theme-solarized_light"]
|
|
||||||
["ace-builds/src-noconflict/keybinding-vim"]
|
|
||||||
[reagent.core :as r]
|
|
||||||
[reagent.dom :as rdom]))
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(def current-evaluation (r/atom []))
|
|
||||||
; (def current-index (r/atom 5))
|
|
||||||
(defonce current-index (r/atom 0))
|
|
||||||
|
|
||||||
(def +split-width+ "4px")
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn gen-key []
|
|
||||||
(js/self.crypto.randomUUID))
|
|
||||||
|
|
||||||
(defn add-key [e]
|
|
||||||
(let [uuid (js/self.crypto.randomUUID)]
|
|
||||||
(match e
|
|
||||||
[tag props & children] (concat [tag (assoc props :key uuid)] children))))
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(declare ppr-node)
|
|
||||||
(declare ppr-node*)
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn Root [props & children]
|
|
||||||
[:> Resplit.Root (assoc props :class "split-root")
|
|
||||||
[:<> children]])
|
|
||||||
|
|
||||||
(defn Pane [props & children]
|
|
||||||
[:> Resplit.Pane (assoc props :class "split-pane")
|
|
||||||
[:<> children]])
|
|
||||||
|
|
||||||
(defn Splitter [props & children]
|
|
||||||
[:> Resplit.Splitter (assoc props :class "split-splitter")
|
|
||||||
[:<> children]])
|
|
||||||
|
|
||||||
(defn Header [text]
|
|
||||||
[:h5 {:class "view-header"}
|
|
||||||
text])
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn Dump []
|
|
||||||
[:div {:class "pane-content dump-view"}
|
|
||||||
[Header "Dump"]])
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn HeapEntry [heap addr-key]
|
|
||||||
(let [addr (js/Number (name addr-key))]
|
|
||||||
[:div {:class "heap-entry"
|
|
||||||
:key (gen-key)}
|
|
||||||
[:div {:class "heap-entry-addr"}
|
|
||||||
(cl-format nil "&~3D" addr)]
|
|
||||||
[:div {:class "heap-entry-node"}
|
|
||||||
(ppr-node heap addr)]]))
|
|
||||||
|
|
||||||
(defn Heap [heap]
|
|
||||||
[:div {:class "pane-content heap-view"}
|
|
||||||
[Header "Heap"]
|
|
||||||
[:div {:class "heap-entry-container"}
|
|
||||||
[:<> (map (partial HeapEntry heap) (keys heap))]]])
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn deref-addr [heap addr]
|
|
||||||
(get heap
|
|
||||||
(keyword (str addr))
|
|
||||||
nil))
|
|
||||||
|
|
||||||
(defn words [& ws]
|
|
||||||
(->> ws
|
|
||||||
(map str)
|
|
||||||
(str/join \space)))
|
|
||||||
|
|
||||||
(defn maybe-parens [c s]
|
|
||||||
(if c
|
|
||||||
(str "(" s ")")
|
|
||||||
s))
|
|
||||||
|
|
||||||
(def app-prec 10)
|
|
||||||
(def app-prec+1 11)
|
|
||||||
(def app-prec-1 9)
|
|
||||||
|
|
||||||
(defn ppr-list [heap addrs]
|
|
||||||
(match addrs
|
|
||||||
[] "[]"
|
|
||||||
_ (str "[" (->> addrs
|
|
||||||
(map (partial ppr-node* 0 heap))
|
|
||||||
(interpose ", ")
|
|
||||||
(concat)) "]")))
|
|
||||||
|
|
||||||
(defn ppr-node* [p heap addr]
|
|
||||||
(match (deref-addr heap addr)
|
|
||||||
{:tag "NGlobal" :contents [arity code]}
|
|
||||||
(maybe-parens (> p 0)
|
|
||||||
(words "Global" arity "<code>"))
|
|
||||||
|
|
||||||
{:tag "NNum" :contents k}
|
|
||||||
(maybe-parens (> p 0)
|
|
||||||
(words "Number" k))
|
|
||||||
|
|
||||||
{:tag "NAp" :contents [f x]}
|
|
||||||
(maybe-parens (> p app-prec)
|
|
||||||
(words (ppr-node* app-prec heap f)
|
|
||||||
"@"
|
|
||||||
(ppr-node* app-prec+1 heap x)))
|
|
||||||
|
|
||||||
{:tag "NConstr" :contents [tag as]}
|
|
||||||
(maybe-parens (> p 0)
|
|
||||||
(words "Constructor"
|
|
||||||
tag
|
|
||||||
(ppr-list heap as)))
|
|
||||||
|
|
||||||
{:tag "NInd" :contents addr*}
|
|
||||||
(maybe-parens (> p 0)
|
|
||||||
(words "Indirection"
|
|
||||||
(ppr-node* app-prec+1 heap addr*)))
|
|
||||||
|
|
||||||
{:tag "NUninitialised"}
|
|
||||||
"<Uninitialised>"
|
|
||||||
|
|
||||||
{:tag "NMarked" :contents node*}
|
|
||||||
(maybe-parens (> p 0)
|
|
||||||
(words "Marked"
|
|
||||||
"<node>"))
|
|
||||||
|
|
||||||
nil (str "<broken pointer: &" addr ">")
|
|
||||||
|
|
||||||
a (str "other" a)))
|
|
||||||
|
|
||||||
(defn ppr-node [heap addr]
|
|
||||||
(ppr-node* 0 heap addr))
|
|
||||||
|
|
||||||
(defn StackEntry [heap addr]
|
|
||||||
[:div {:class "stack-entry"
|
|
||||||
:key (gen-key)}
|
|
||||||
(ppr-node heap addr)
|
|
||||||
[:div {:class "stack-entry-addr"}
|
|
||||||
(str "&" addr)]])
|
|
||||||
|
|
||||||
(defn StackEntryContainer [children]
|
|
||||||
[:div {:class "stack-entry-container even"}
|
|
||||||
[:<> children]])
|
|
||||||
|
|
||||||
(defn Stack [heap s]
|
|
||||||
[:div {:class "pane-content stack-view"}
|
|
||||||
[Header "Stack"]
|
|
||||||
[StackEntryContainer (map (partial StackEntry heap) (reverse s))]])
|
|
||||||
|
|
||||||
#_ (swap! current-index #(+ % 1))
|
|
||||||
#_ (swap! current-index #(- % 1))
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn ppr-instr [{op :tag c :contents}]
|
|
||||||
(match op
|
|
||||||
"CaseJump" (words op "<cases>")
|
|
||||||
_ (words op c)))
|
|
||||||
|
|
||||||
(defn Instr [instr]
|
|
||||||
[:code {:class "instr"
|
|
||||||
:key (gen-key)}
|
|
||||||
(ppr-instr instr)])
|
|
||||||
|
|
||||||
(defn CodeButtons []
|
|
||||||
[:div {:class "code-button-container"}
|
|
||||||
[:button {:onClick #(swap! current-index dec)}
|
|
||||||
"<"]
|
|
||||||
[:code @current-index]
|
|
||||||
[:button {:onClick #(swap! current-index inc)}
|
|
||||||
">"]])
|
|
||||||
|
|
||||||
(defn CodeInstrContainer [children]
|
|
||||||
[:div {:class (if (even? (count children))
|
|
||||||
"code-instr-container even"
|
|
||||||
"code-instr-container odd")}
|
|
||||||
[:<> children]])
|
|
||||||
|
|
||||||
(defn Code [code]
|
|
||||||
[:div {:class "pane-content code-view"}
|
|
||||||
[Header "Next instructions"]
|
|
||||||
[CodeInstrContainer (map Instr code)]
|
|
||||||
[CodeButtons]])
|
|
||||||
|
|
||||||
;------------------------------------------------------------------------------;
|
|
||||||
|
|
||||||
(defn GM [{code :_gmCode
|
|
||||||
stack :_gmStack
|
|
||||||
heap :_gmHeap}]
|
|
||||||
[Root {:direction "horizontal"}
|
|
||||||
[Pane {:order 0 :initialSize "0.333fr"}
|
|
||||||
[Heap heap]]
|
|
||||||
[Splitter {:order 1 :size +split-width+}]
|
|
||||||
[Pane {:order 2 :initialSize "0.333fr"}
|
|
||||||
[Root {:direction "vertical"}
|
|
||||||
[Pane {:order 0 :initialSize "0.5fr"}
|
|
||||||
[Stack heap stack]]
|
|
||||||
[Splitter {:order 1 :size +split-width+}]
|
|
||||||
[Pane {:order 2 :initialSize "0.5fr"}
|
|
||||||
[Code code]]]]
|
|
||||||
[Splitter {:order 3 :size +split-width+}]
|
|
||||||
[Pane {:order 4 :initialSize "0.333fr"}
|
|
||||||
[Dump]]])
|
|
||||||
|
|
||||||
(defn Main []
|
|
||||||
(prn @current-evaluation)
|
|
||||||
(prn @current-index)
|
|
||||||
(if-let [st (nth @current-evaluation
|
|
||||||
@current-index
|
|
||||||
nil)]
|
|
||||||
[GM st]
|
|
||||||
[:h1 "no evaluation"]))
|
|
||||||
|
|
||||||
Reference in New Issue
Block a user