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_OPTS = -a -g -c -i/tmp/t.info
|
||||
ALEX = alex
|
||||
ALEX_OPTS = -g
|
||||
|
||||
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
|
||||
|
||||
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs \
|
||||
$(CABAL_BUILD)/Rlp/AltParse.hs
|
||||
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
|
||||
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
|
||||
|
||||
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
|
||||
|
||||
@@ -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.Parse
|
||||
-- import Core.SystemF
|
||||
import GM
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -19,8 +18,7 @@ driver = forFiles_ $ \f ->
|
||||
withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
|
||||
|
||||
driverSource :: T.Text -> RLPCIO ()
|
||||
driverSource = lexCoreR >=> parseCoreProgR
|
||||
>=> evalProgR >=> printRes
|
||||
driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
|
||||
where
|
||||
printRes = liftIO . print . view _1
|
||||
|
||||
|
||||
12
app/Main.hs
12
app/Main.hs
@@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Lens hiding (argument)
|
||||
import Compiler.RLPC
|
||||
import Compiler.RlpcError
|
||||
import Control.Exception
|
||||
@@ -24,7 +23,6 @@ import Control.Lens.Combinators hiding (argument)
|
||||
|
||||
import CoreDriver qualified
|
||||
import RlpDriver qualified
|
||||
import Server qualified
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
optParser :: ParserInfo RLPCOptions
|
||||
@@ -76,11 +74,7 @@ options = RLPCOptions
|
||||
<> metavar "rlp|core"
|
||||
<> help "the language to be compiled -- see README"
|
||||
)
|
||||
<*> switch
|
||||
( long "server"
|
||||
<> short 's'
|
||||
)
|
||||
<*> many (argument str $ metavar "FILES...")
|
||||
<*> some (argument str $ metavar "FILES...")
|
||||
where
|
||||
infixr 9 #
|
||||
f # x = f x
|
||||
@@ -113,9 +107,7 @@ mmany v = liftA2 (<>) v (mmany v)
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- execParser optParser
|
||||
if opts ^. rlpcServer
|
||||
then Server.server
|
||||
else void $ evalRLPCIO opts dispatch
|
||||
void $ evalRLPCIO opts dispatch
|
||||
|
||||
dispatch :: RLPCIO ()
|
||||
dispatch = getLang >>= \case
|
||||
|
||||
@@ -15,5 +15,5 @@ import GM
|
||||
|
||||
driver :: RLPCIO ()
|
||||
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
|
||||
, Control.Monad.Errorful
|
||||
, Rlp.Syntax
|
||||
, Rlp.Syntax.Backstage
|
||||
, Rlp.Syntax.Types
|
||||
-- , Rlp.Parse.Decls
|
||||
, Rlp.Parse
|
||||
, Rlp.Parse.Associate
|
||||
@@ -50,17 +52,17 @@ library
|
||||
build-tool-depends: happy:happy, alex:alex
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.17 && <4.21
|
||||
build-depends: base >=4.17 && <4.20
|
||||
-- required for happy
|
||||
, array >= 0.5.5 && < 0.6
|
||||
, 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
|
||||
, data-default >= 0.7.1 && < 0.8
|
||||
, data-default-class >= 0.1.2 && < 0.2
|
||||
, hashable >= 1.4.3 && < 1.5
|
||||
, mtl >= 2.3.1 && < 2.4
|
||||
, text >= 2.0.2 && < 2.3
|
||||
, text >= 2.0.2 && < 2.1
|
||||
, unordered-containers >= 0.2.20 && < 0.3
|
||||
, recursion-schemes >= 5.2.2 && < 5.3
|
||||
, data-fix >= 0.3.2 && < 0.4
|
||||
@@ -73,14 +75,11 @@ library
|
||||
, effectful-core ^>=2.3.0.0
|
||||
, deriving-compat ^>=0.6.0
|
||||
, these >=0.2 && <2.0
|
||||
, aeson
|
||||
, free >=5.2
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
|
||||
ghc-options:
|
||||
-fdefer-typed-holes
|
||||
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
TypeFamilies
|
||||
@@ -90,14 +89,12 @@ library
|
||||
DerivingVia
|
||||
StandaloneDeriving
|
||||
DerivingStrategies
|
||||
PartialTypeSignatures
|
||||
|
||||
executable rlpc
|
||||
import: warnings
|
||||
main-is: Main.hs
|
||||
other-modules: RlpDriver
|
||||
, CoreDriver
|
||||
, Server
|
||||
|
||||
build-depends: base >=4.17.0.0 && <4.20.0.0
|
||||
, rlp
|
||||
@@ -105,9 +102,7 @@ executable rlpc
|
||||
, mtl >= 2.3.1 && < 2.4
|
||||
, unordered-containers >= 0.2.20 && < 0.3
|
||||
, lens >=5.2.3 && <6.0
|
||||
, text >= 2.0.2 && < 2.3
|
||||
, aeson
|
||||
, websockets
|
||||
, text >= 2.0.2 && < 2.1
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2021
|
||||
@@ -124,8 +119,10 @@ test-suite rlp-test
|
||||
, QuickCheck
|
||||
, hspec ==2.*
|
||||
, microlens
|
||||
, lens >=5.2.3 && <6.0
|
||||
other-modules: Arith
|
||||
, GMSpec
|
||||
, Core.HindleyMilnerSpec
|
||||
, Compiler.TypesSpec
|
||||
build-tool-depends: hspec-discover:hspec-discover
|
||||
|
||||
|
||||
@@ -12,7 +12,6 @@ module Compiler.JustRun
|
||||
, justParseCore
|
||||
, justTypeCheckCore
|
||||
, justHdbg
|
||||
, justLexParseGmEval
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -48,10 +47,6 @@ justParseCore s = parse (T.pack s)
|
||||
& rlpcToEither
|
||||
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 s = typechk (T.pack s)
|
||||
& rlpcToEither
|
||||
|
||||
@@ -26,7 +26,6 @@ module Compiler.RLPC
|
||||
, DebugFlag(..), CompilerFlag(..)
|
||||
-- ** Lenses
|
||||
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
|
||||
, rlpcServer
|
||||
-- * Misc. MTL-style functions
|
||||
, liftErrorful, hoistRlpcT
|
||||
-- * Misc. Rlpc Monad -related types
|
||||
@@ -121,7 +120,6 @@ data RLPCOptions = RLPCOptions
|
||||
, _rlpcEvaluator :: Evaluator
|
||||
, _rlpcHeapTrigger :: Int
|
||||
, _rlpcLanguage :: Maybe Language
|
||||
, _rlpcServer :: Bool
|
||||
, _rlpcInputFiles :: [FilePath]
|
||||
}
|
||||
deriving Show
|
||||
@@ -143,7 +141,6 @@ instance Default RLPCOptions where
|
||||
, _rlpcHeapTrigger = 200
|
||||
, _rlpcInputFiles = []
|
||||
, _rlpcLanguage = Nothing
|
||||
, _rlpcServer = False
|
||||
}
|
||||
|
||||
-- debug flags are passed with -dFLAG
|
||||
@@ -223,9 +220,9 @@ docRlpcErr msg = header
|
||||
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
||||
srclines = ["", "<problematic source code>", ""]
|
||||
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 ": "
|
||||
<> errorColour "error" <> msgColour ":"
|
||||
|
||||
@@ -23,9 +23,6 @@ import Data.Text qualified as T
|
||||
import GHC.Exts (IsString(..))
|
||||
import Control.Lens
|
||||
import Compiler.Types
|
||||
import GHC.Generics ( Generic, Generic1
|
||||
, Generically(..), Generically1(..) )
|
||||
import Data.Aeson (ToJSON1(..), ToJSON(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data MsgEnvelope e = MsgEnvelope
|
||||
@@ -33,18 +30,10 @@ data MsgEnvelope e = MsgEnvelope
|
||||
, _msgDiagnostic :: e
|
||||
, _msgSeverity :: Severity
|
||||
}
|
||||
deriving (Functor, Show, Generic, Generic1)
|
||||
deriving (Functor, Show)
|
||||
|
||||
newtype RlpcError = Text [Text]
|
||||
deriving (Show, Generic)
|
||||
|
||||
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
|
||||
deriving Show
|
||||
|
||||
instance IsString RlpcError where
|
||||
fromString = Text . pure . T.pack
|
||||
@@ -58,10 +47,7 @@ instance IsRlpcError RlpcError where
|
||||
data Severity = SevWarning
|
||||
| SevError
|
||||
| SevDebug Text -- ^ Tag
|
||||
deriving (Show, Generic)
|
||||
|
||||
deriving via Generically Severity
|
||||
instance ToJSON Severity
|
||||
deriving Show
|
||||
|
||||
makeLenses ''MsgEnvelope
|
||||
|
||||
|
||||
@@ -1,36 +1,81 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Compiler.Types
|
||||
( SrcSpan(..)
|
||||
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
|
||||
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
|
||||
, pattern (:<$)
|
||||
, Located(..)
|
||||
, HasLocation(..)
|
||||
, _Located
|
||||
, located
|
||||
, nolo
|
||||
, (<<~), (<~>), (<#>)
|
||||
, nolo, nolo'
|
||||
|
||||
, (<~>), (~>), (~~>), (<~~)
|
||||
|
||||
, comb2, comb3, comb4
|
||||
, lochead
|
||||
|
||||
-- * Re-exports
|
||||
, Comonad
|
||||
, Comonad(extract)
|
||||
, Apply
|
||||
, Bind
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
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.Bind
|
||||
import Control.Lens hiding ((<<~))
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import GHC.Generics ( Generic, Generic1
|
||||
, Generically(..), Generically1(..) )
|
||||
import Data.Aeson (ToJSON1(..), ToJSON(..))
|
||||
import Data.Functor.Compose
|
||||
import Data.Functor.Foldable
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Fix hiding (cata, ana)
|
||||
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)
|
||||
data Located a = Located SrcSpan a
|
||||
deriving (Show, Lift, Functor)
|
||||
|
||||
located :: Lens (Located a) (Located b) a b
|
||||
located = lens extract ($>)
|
||||
data Floc f = Floc SrcSpan (f (Floc f))
|
||||
|
||||
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
|
||||
liftF2 f (Located sa p) (Located sb q)
|
||||
@@ -50,56 +95,136 @@ data SrcSpan = SrcSpan
|
||||
!Int -- ^ Column
|
||||
!Int -- ^ Absolute
|
||||
!Int -- ^ Length
|
||||
deriving (Show, Lift, Generic)
|
||||
|
||||
deriving via Generically SrcSpan
|
||||
instance ToJSON SrcSpan
|
||||
deriving (Show, Eq, Lift)
|
||||
|
||||
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
||||
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
||||
(\ (a,b,c,d) -> SrcSpan a b c d)
|
||||
|
||||
srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
|
||||
srcspanLine = tupling . _1
|
||||
srcspanColumn = tupling . _2
|
||||
srcspanAbs = tupling . _3
|
||||
srcspanLen = tupling . _4
|
||||
srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
|
||||
srcSpanLine = tupling . _1
|
||||
srcSpanColumn = tupling . _2
|
||||
srcSpanAbs = tupling . _3
|
||||
srcSpanLen = tupling . _4
|
||||
|
||||
-- | debug tool
|
||||
nolo :: a -> Located a
|
||||
nolo = Located (SrcSpan 0 0 0 0)
|
||||
|
||||
nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
|
||||
nolo' as = SrcSpan 0 0 0 0 :< as
|
||||
|
||||
instance Semigroup SrcSpan where
|
||||
-- multiple identities? what are the consequences of this...?
|
||||
SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
|
||||
SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
|
||||
|
||||
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
|
||||
l = min la lb
|
||||
c = min ca cb
|
||||
a = min aa ab
|
||||
s = case aa `compare` ab of
|
||||
EQ -> max sa sb
|
||||
LT -> max sa (ab + lb - aa)
|
||||
GT -> max sb (aa + la - ab)
|
||||
LT -> max sa (ab + sb - aa)
|
||||
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
|
||||
mc <~> ma = mc >>- \f -> ma =>> f
|
||||
data GetSetLens (k :: GetOrSet) s t a b :: Type where
|
||||
Getter_ :: (s -> a) -> GetSetLens Get s t a b
|
||||
Setter_ :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
|
||||
GetterSetter :: (CanGet k', CanSet k')
|
||||
=> (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
|
||||
|
||||
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
|
||||
fab <#> a = fmap ($ a) fab
|
||||
type family Access (k :: GetOrSet) f where
|
||||
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
|
||||
|
||||
|
||||
@@ -28,27 +28,10 @@ import Data.Map.Strict qualified as M
|
||||
import Data.List (intersect)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import Control.Lens
|
||||
|
||||
import Data.Aeson
|
||||
import GHC.Generics ( Generic1, Generic
|
||||
, Generically1(..), Generically(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data Heap a = Heap [Addr] (Map Addr a)
|
||||
deriving (Show, Generic, Generic1)
|
||||
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)
|
||||
deriving Show
|
||||
|
||||
type Addr = Int
|
||||
|
||||
|
||||
72
src/GM.hs
72
src/GM.hs
@@ -18,8 +18,6 @@ module GM
|
||||
, finalStateOf
|
||||
, resultOf
|
||||
, resultOfExpr
|
||||
, compile
|
||||
, eval
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -44,12 +42,6 @@ import Data.String (IsString)
|
||||
import Data.Heap
|
||||
import Debug.Trace
|
||||
import Compiler.RLPC
|
||||
|
||||
-- for visualisation
|
||||
import Data.Aeson hiding (Key)
|
||||
import Data.Aeson.Text
|
||||
import GHC.Generics (Generic, Generically(..))
|
||||
|
||||
import Core2Core
|
||||
import Core
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -86,7 +78,7 @@ data GmState = GmState
|
||||
, _gmEnv :: Env
|
||||
, _gmStats :: Stats
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving Show
|
||||
|
||||
type Code = [Instr]
|
||||
type Stack = [Addr]
|
||||
@@ -96,7 +88,7 @@ type GmHeap = Heap Node
|
||||
|
||||
data Key = NameKey Name
|
||||
| ConstrKey Tag Int
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- >> [ref/Instr]
|
||||
data Instr = Unwind
|
||||
@@ -119,7 +111,7 @@ data Instr = Unwind
|
||||
| Split Int
|
||||
| Print
|
||||
| Halt
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving (Show, Eq)
|
||||
-- << [ref/Instr]
|
||||
|
||||
data Node = NNum Int
|
||||
@@ -132,7 +124,7 @@ data Node = NNum Int
|
||||
| NUninitialised
|
||||
| NConstr Tag [Addr] -- NConstr Tag Components
|
||||
| NMarked Node
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- TODO: log executed instructions
|
||||
data Stats = Stats
|
||||
@@ -142,7 +134,7 @@ data Stats = Stats
|
||||
, _stsDereferences :: Int
|
||||
, _stsGCCycles :: Int
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving Show
|
||||
|
||||
instance Default Stats where
|
||||
def = Stats 0 0 0 0 0
|
||||
@@ -186,49 +178,19 @@ hdbgProg p hio = do
|
||||
|
||||
evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
|
||||
evalProgR p = do
|
||||
putState `traverse_` states
|
||||
putStats sts
|
||||
pure res
|
||||
(renderOut . showState) `traverse_` states
|
||||
renderOut . showStats $ sts
|
||||
pure (res, sts)
|
||||
where
|
||||
renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
|
||||
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
|
||||
|
||||
sts = final ^. gmStats
|
||||
-- the address of the result should be the one and only stack entry
|
||||
[resAddr] = final ^. gmStack
|
||||
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 st = st : rest
|
||||
where
|
||||
@@ -1098,17 +1060,3 @@ resultOfExpr e = resultOf $
|
||||
[ 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(..)
|
||||
, lexToken
|
||||
, lexStream
|
||||
, lexStream'
|
||||
, lexDebug
|
||||
, lexCont
|
||||
, popLexState
|
||||
@@ -29,6 +30,7 @@ import Data.Word
|
||||
import Data.Default
|
||||
import Control.Lens
|
||||
|
||||
import Compiler.Types
|
||||
import Debug.Trace
|
||||
import Rlp.Parse.Types
|
||||
}
|
||||
@@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a
|
||||
lexCont = (lexToken >>=)
|
||||
|
||||
lexStream :: P [RlpToken]
|
||||
lexStream = do
|
||||
t <- lexToken
|
||||
case t of
|
||||
Located _ TokenEOF -> pure [TokenEOF]
|
||||
Located _ t -> (t:) <$> lexStream
|
||||
lexStream = fmap extract <$> lexStream'
|
||||
|
||||
lexStream' :: P [Located RlpToken]
|
||||
lexStream' = lexToken >>= \case
|
||||
t@(Located _ TokenEOF) -> pure [t]
|
||||
t -> (t:) <$> lexStream'
|
||||
|
||||
lexDebug :: (Located RlpToken -> P a) -> P a
|
||||
lexDebug k = do
|
||||
|
||||
252
src/Rlp/Parse.y
252
src/Rlp/Parse.y
@@ -5,15 +5,17 @@ module Rlp.Parse
|
||||
, parseRlpProgR
|
||||
, parseRlpExpr
|
||||
, parseRlpExprR
|
||||
, runP'
|
||||
)
|
||||
where
|
||||
import Compiler.RlpcError
|
||||
import Compiler.RLPC
|
||||
import Control.Comonad.Cofree
|
||||
import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Associate
|
||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~))
|
||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
@@ -71,12 +73,11 @@ import Compiler.Types
|
||||
|
||||
%%
|
||||
|
||||
StandaloneProgram :: { RlpProgram RlpcPs }
|
||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||
| VL DeclsV VR {% mkProgram $2 }
|
||||
StandaloneProgram :: { Program RlpcPs SrcSpan }
|
||||
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
|
||||
|
||||
StandaloneExpr :: { RlpExpr RlpcPs }
|
||||
: VL Expr VR { extract $2 }
|
||||
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: VL Expr VR { $2 }
|
||||
|
||||
VL :: { () }
|
||||
VL : vlbrace { () }
|
||||
@@ -85,125 +86,105 @@ VR :: { () }
|
||||
VR : vrbrace { () }
|
||||
| error { () }
|
||||
|
||||
Decls :: { [Decl' RlpcPs] }
|
||||
Decls : Decl ';' Decls { $1 : $3 }
|
||||
| Decl ';' { [$1] }
|
||||
| Decl { [$1] }
|
||||
VS :: { () }
|
||||
VS : ';' { () }
|
||||
| vsemi { () }
|
||||
|
||||
DeclsV :: { [Decl' RlpcPs] }
|
||||
DeclsV : Decl VS DeclsV { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
VS :: { Located RlpToken }
|
||||
VS : ';' { $1 }
|
||||
| vsemi { $1 }
|
||||
|
||||
Decl :: { Decl' RlpcPs }
|
||||
Decl :: { Decl RlpcPs SrcSpan }
|
||||
: FunDecl { $1 }
|
||||
| TySigDecl { $1 }
|
||||
| DataDecl { $1 }
|
||||
| InfixDecl { $1 }
|
||||
|
||||
TySigDecl :: { Decl' RlpcPs }
|
||||
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
|
||||
TySigDecl :: { Decl RlpcPs SrcSpan }
|
||||
: Var '::' Type { TySigD [$1] $3 }
|
||||
|
||||
InfixDecl :: { Decl' RlpcPs }
|
||||
: InfixWord litint InfixOp { $1 =>> \w ->
|
||||
InfixD (extract $1) (extractInt $ extract $2)
|
||||
(extract $3) }
|
||||
InfixDecl :: { Decl RlpcPs SrcSpan }
|
||||
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
|
||||
|
||||
InfixWord :: { Located Assoc }
|
||||
: infixl { $1 \$> InfixL }
|
||||
| infixr { $1 \$> InfixR }
|
||||
| infix { $1 \$> Infix }
|
||||
InfixWord :: { Assoc }
|
||||
: infixl { InfixL }
|
||||
| infixr { InfixR }
|
||||
| infix { Infix }
|
||||
|
||||
DataDecl :: { Decl' RlpcPs }
|
||||
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
|
||||
DataDecl :: { Decl RlpcPs SrcSpan }
|
||||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||
|
||||
TyParams :: { [PsName] }
|
||||
: {- epsilon -} { [] }
|
||||
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
|
||||
| TyParams varname { $1 `snoc` extractName $2 }
|
||||
|
||||
DataCons :: { [ConAlt RlpcPs] }
|
||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||
| DataCon { [$1] }
|
||||
|
||||
DataCon :: { ConAlt RlpcPs }
|
||||
: Con Type1s { ConAlt (extract $1) $2 }
|
||||
: Con Type1s { ConAlt $1 $2 }
|
||||
|
||||
Type1s :: { [RlpType' RlpcPs] }
|
||||
Type1s :: { [Ty RlpcPs] }
|
||||
: {- epsilon -} { [] }
|
||||
| Type1s Type1 { $1 `snoc` $2 }
|
||||
|
||||
Type1 :: { RlpType' RlpcPs }
|
||||
Type1 :: { Ty RlpcPs }
|
||||
: '(' Type ')' { $2 }
|
||||
| conname { fmap ConT (mkPsName $1) }
|
||||
| varname { fmap VarT (mkPsName $1) }
|
||||
| conname { ConT (extractName $1) }
|
||||
| varname { VarT (extractName $1) }
|
||||
|
||||
Type :: { RlpType' RlpcPs }
|
||||
: Type '->' Type { FunT <<~ $1 <~> $3 }
|
||||
Type :: { Ty RlpcPs }
|
||||
: Type '->' Type { FunT $1 $3 }
|
||||
| TypeApp { $1 }
|
||||
|
||||
TypeApp :: { RlpType' RlpcPs }
|
||||
TypeApp :: { Ty RlpcPs }
|
||||
: Type1 { $1 }
|
||||
| TypeApp Type1 { AppT <<~ $1 <~> $2 }
|
||||
| TypeApp Type1 { AppT $1 $2 }
|
||||
|
||||
FunDecl :: { Decl' RlpcPs }
|
||||
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
||||
FunD (extract $1) $2 e Nothing }
|
||||
FunDecl :: { Decl RlpcPs SrcSpan }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||||
|
||||
Params :: { [Pat' RlpcPs] }
|
||||
Params :: { [Pat RlpcPs] }
|
||||
Params : {- epsilon -} { [] }
|
||||
| Params Pat1 { $1 `snoc` $2 }
|
||||
|
||||
Pat :: { Pat' RlpcPs }
|
||||
: Con Pat1s { $1 =>> \cn ->
|
||||
ConP (extract $1) $2 }
|
||||
Pat :: { Pat RlpcPs }
|
||||
: Con Pat1s { ConP $1 $2 }
|
||||
| Pat1 { $1 }
|
||||
|
||||
Pat1s :: { [Pat' RlpcPs] }
|
||||
Pat1s :: { [Pat RlpcPs] }
|
||||
: Pat1s Pat1 { $1 `snoc` $2 }
|
||||
| Pat1 { [$1] }
|
||||
|
||||
Pat1 :: { Pat' RlpcPs }
|
||||
: Con { fmap (`ConP` []) $1 }
|
||||
| Var { fmap VarP $1 }
|
||||
| Lit { LitP <<= $1 }
|
||||
| '(' Pat ')' { $1 .> $2 <. $3 }
|
||||
Pat1 :: { Pat RlpcPs }
|
||||
: Con { ConP $1 [] }
|
||||
| Var { VarP $1 }
|
||||
| Lit { LitP $1 }
|
||||
| '(' Pat ')' { $2 }
|
||||
|
||||
Expr :: { RlpExpr' RlpcPs }
|
||||
Expr :: { Expr' RlpcPs SrcSpan }
|
||||
-- infixities delayed till next release :(
|
||||
-- : Expr1 InfixOp Expr { $2 =>> \o ->
|
||||
-- OAppE (extract o) $1 $3 }
|
||||
: TempInfixExpr { $1 }
|
||||
-- : Expr1 InfixOp Expr { undefined }
|
||||
: AppExpr { $1 }
|
||||
| TempInfixExpr { $1 }
|
||||
| LetExpr { $1 }
|
||||
| CaseExpr { $1 }
|
||||
| AppExpr { $1 }
|
||||
|
||||
TempInfixExpr :: { RlpExpr' RlpcPs }
|
||||
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
||||
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
||||
| Expr1 InfixOp Expr1 { $2 =>> \o ->
|
||||
OAppE (extract o) $1 $3 }
|
||||
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
|
||||
|
||||
AppExpr :: { RlpExpr' RlpcPs }
|
||||
AppExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: Expr1 { $1 }
|
||||
| AppExpr Expr1 { AppE <<~ $1 <~> $2 }
|
||||
| AppExpr Expr1 { comb2 AppEF $1 $2 }
|
||||
|
||||
LetExpr :: { RlpExpr' RlpcPs }
|
||||
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
|
||||
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 }
|
||||
LetExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
|
||||
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
|
||||
|
||||
CaseExpr :: { RlpExpr' RlpcPs }
|
||||
: case Expr of layout0(CaseAlt)
|
||||
{ CaseE <<~ $2 <#> $4 }
|
||||
CaseExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
|
||||
|
||||
-- TODO: where-binds
|
||||
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
|
||||
: Alt { ($1, []) }
|
||||
|
||||
Alt :: { Alt RlpcPs }
|
||||
: Pat '->' Expr { AltA $1 $3 }
|
||||
Alt :: { Alt' RlpcPs SrcSpan }
|
||||
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
|
||||
|
||||
-- layout0(p : β) :: [β]
|
||||
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) sep p { $1 `snoc` $3 }
|
||||
|
||||
Binding :: { Binding' RlpcPs }
|
||||
: Pat '=' Expr { PatB <<~ $1 <~> $3 }
|
||||
Binding :: { Binding' RlpcPs SrcSpan }
|
||||
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
|
||||
|
||||
Expr1 :: { RlpExpr' RlpcPs }
|
||||
: '(' Expr ')' { $1 .> $2 <. $3 }
|
||||
| Lit { fmap LitE $1 }
|
||||
| Var { fmap VarE $1 }
|
||||
| Con { fmap VarE $1 }
|
||||
Expr1 :: { Expr' RlpcPs SrcSpan }
|
||||
: '(' Expr ')' { $2 }
|
||||
| Lit { nolo' $ LitEF $1 }
|
||||
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
|
||||
InfixOp :: { Located PsName }
|
||||
: consym { mkPsName $1 }
|
||||
| varsym { mkPsName $1 }
|
||||
InfixOp :: { PsName }
|
||||
: consym { extractName $1 }
|
||||
| varsym { extractName $1 }
|
||||
|
||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||
Lit :: { Lit' RlpcPs }
|
||||
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
||||
Lit :: { Lit RlpcPs }
|
||||
: litint { $1 ^. to extract
|
||||
. singular _TokenLitInt
|
||||
. to IntL }
|
||||
|
||||
Var :: { Located PsName }
|
||||
Var : varname { mkPsName $1 }
|
||||
| varsym { mkPsName $1 }
|
||||
Var :: { PsName }
|
||||
Var : varname { $1 <&> view (singular _TokenVarName) }
|
||||
| varsym { $1 <&> view (singular _TokenVarSym) }
|
||||
|
||||
Con :: { Located PsName }
|
||||
: conname { mkPsName $1 }
|
||||
Con :: { PsName }
|
||||
: 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
|
||||
where
|
||||
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
|
||||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||||
addDebugMsg @_ @String "dump-parsed" $ show a
|
||||
@@ -276,37 +287,48 @@ extractInt :: RlpToken -> Int
|
||||
extractInt (TokenLitInt n) = n
|
||||
extractInt _ = error "extractInt: ugh"
|
||||
|
||||
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
||||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||||
mkProgram ds = do
|
||||
pt <- use psOpTable
|
||||
pure $ RlpProgram (associate pt <$> ds)
|
||||
|
||||
parseError :: (Located RlpToken, [String]) -> P a
|
||||
parseError ((Located ss t), exp) = addFatal $
|
||||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
||||
|
||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
|
||||
mkInfixD a p n = do
|
||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||||
opl = psOpTable . at n
|
||||
opl <~ (use opl >>= \case
|
||||
Just o -> addWoundHere l e >> pure (Just o) where
|
||||
e = RlpParErrDuplicateInfixD n
|
||||
l = T.length n
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pos <- use (psInput . aiPos)
|
||||
pure $ Located (spanFromPos pos 0) (InfixD a p n)
|
||||
pure $ Program (associate pt <$> ds)
|
||||
|
||||
intOfToken :: Located RlpToken -> Int
|
||||
intOfToken (Located _ (TokenLitInt n)) = n
|
||||
|
||||
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
|
||||
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
|
||||
tempInfixExprErr (Located a _) (Located b _) =
|
||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||
, "In the mean time, don't mix any infix operators."
|
||||
]
|
||||
|
||||
--}
|
||||
|
||||
_litint :: Getter (Located RlpToken) Int
|
||||
_litint = to extract
|
||||
. singular _TokenLitInt
|
||||
|
||||
tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
|
||||
tempInfixExprErr (a :< _) (b :< _) =
|
||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||
, "In the mean time, don't mix any infix operators."
|
||||
]
|
||||
|
||||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||||
mkProgram ds = do
|
||||
pt <- use psOpTable
|
||||
pure $ Program (associate pt <$> ds)
|
||||
|
||||
extractName :: Located RlpToken -> PsName
|
||||
extractName (Located ss (TokenVarSym n)) = Located ss n
|
||||
extractName (Located ss (TokenVarName n)) = Located ss n
|
||||
extractName (Located ss (TokenConName n)) = Located ss n
|
||||
extractName (Located ss (TokenConSym n)) = Located ss n
|
||||
|
||||
parseError :: (Located RlpToken, [String]) -> P a
|
||||
parseError ((Located ss t), exp) = addFatal $
|
||||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ import Rlp.Parse.Types
|
||||
import Rlp.Syntax
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
|
||||
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
|
||||
associate _ p = p
|
||||
|
||||
{-# WARNING associate "unimplemented" #-}
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Rlp.Parse.Types
|
||||
(
|
||||
-- * Trees That Grow
|
||||
@@ -17,10 +18,9 @@ module Rlp.Parse.Types
|
||||
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
||||
, Located(..), PsName
|
||||
-- ** Lenses
|
||||
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
|
||||
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
||||
|
||||
, (<<~), (<~>)
|
||||
|
||||
-- * Error handling
|
||||
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
||||
, addFatal, addWound, addFatalHere, addWoundHere
|
||||
@@ -28,6 +28,7 @@ module Rlp.Parse.Types
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Core.Syntax (Name)
|
||||
import Text.Show.Deriving
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Errorful
|
||||
@@ -53,34 +54,9 @@ import Compiler.Types
|
||||
|
||||
data RlpcPs
|
||||
|
||||
type instance XRec RlpcPs a = Located a
|
||||
type instance IdP RlpcPs = PsName
|
||||
type instance NameP RlpcPs = PsName
|
||||
|
||||
type instance XFunD RlpcPs = ()
|
||||
type instance XDataD RlpcPs = ()
|
||||
type instance XInfixD RlpcPs = ()
|
||||
type instance XTySigD RlpcPs = ()
|
||||
type instance XXDeclD RlpcPs = ()
|
||||
|
||||
type instance XLetE RlpcPs = ()
|
||||
type instance XLetrecE RlpcPs = ()
|
||||
type instance XVarE RlpcPs = ()
|
||||
type instance XLamE RlpcPs = ()
|
||||
type instance XCaseE RlpcPs = ()
|
||||
type instance XIfE RlpcPs = ()
|
||||
type instance XAppE RlpcPs = ()
|
||||
type instance XLitE RlpcPs = ()
|
||||
type instance XParE RlpcPs = ()
|
||||
type instance XOAppE RlpcPs = ()
|
||||
type instance XXRlpExprE RlpcPs = ()
|
||||
|
||||
type PsName = Text
|
||||
|
||||
instance MapXRec RlpcPs where
|
||||
mapXRec = fmap
|
||||
|
||||
instance UnXRec RlpcPs where
|
||||
unXRec = extract
|
||||
type PsName = Located Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -118,10 +94,10 @@ data RlpToken
|
||||
-- literals
|
||||
= TokenLitInt Int
|
||||
-- identifiers
|
||||
| TokenVarName Name
|
||||
| TokenConName Name
|
||||
| TokenVarSym Name
|
||||
| TokenConSym Name
|
||||
| TokenVarName Text
|
||||
| TokenConName Text
|
||||
| TokenVarSym Text
|
||||
| TokenConSym Text
|
||||
-- reserved words
|
||||
| TokenData
|
||||
| TokenCase
|
||||
@@ -152,6 +128,31 @@ data RlpToken
|
||||
| TokenEOF
|
||||
deriving (Show)
|
||||
|
||||
_TokenLitInt :: Prism' RlpToken Int
|
||||
_TokenLitInt = prism TokenLitInt $ \case
|
||||
TokenLitInt n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenVarName :: Prism' RlpToken Text
|
||||
_TokenVarName = prism TokenVarName $ \case
|
||||
TokenVarName n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenVarSym :: Prism' RlpToken Text
|
||||
_TokenVarSym = prism TokenVarSym $ \case
|
||||
TokenVarSym n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenConName :: Prism' RlpToken Text
|
||||
_TokenConName = prism TokenConName $ \case
|
||||
TokenConName n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenConSym :: Prism' RlpToken Text
|
||||
_TokenConSym = prism TokenConSym $ \case
|
||||
TokenConSym n -> Right n
|
||||
x -> Left x
|
||||
|
||||
newtype P a = P {
|
||||
runP :: ParseState
|
||||
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||
@@ -281,13 +282,14 @@ initAlexInput s = AlexInput
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving instance Lift (RlpProgram RlpcPs)
|
||||
deriving instance Lift (Decl RlpcPs)
|
||||
deriving instance Lift (Pat RlpcPs)
|
||||
deriving instance Lift (Lit RlpcPs)
|
||||
deriving instance Lift (RlpExpr RlpcPs)
|
||||
deriving instance Lift (Binding RlpcPs)
|
||||
deriving instance Lift (RlpType RlpcPs)
|
||||
deriving instance Lift (Alt RlpcPs)
|
||||
deriving instance Lift (ConAlt RlpcPs)
|
||||
|
||||
-- deriving instance Lift (Program RlpcPs)
|
||||
-- deriving instance Lift (Decl RlpcPs)
|
||||
-- deriving instance Lift (Pat RlpcPs)
|
||||
-- deriving instance Lift (Lit RlpcPs)
|
||||
-- deriving instance Lift (Expr RlpcPs)
|
||||
-- deriving instance Lift (Binding RlpcPs)
|
||||
-- deriving instance Lift (Ty RlpcPs)
|
||||
-- deriving instance Lift (Alt RlpcPs)
|
||||
-- deriving instance Lift (ConAlt RlpcPs)
|
||||
|
||||
|
||||
@@ -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
|
||||
(
|
||||
-- * AST
|
||||
RlpProgram(..)
|
||||
, progDecls
|
||||
, Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
|
||||
, Pat(..), Pat'
|
||||
, Alt(..), Where
|
||||
, Assoc(..)
|
||||
, Lit(..), Lit'
|
||||
, RlpType(..), RlpType'
|
||||
, ConAlt(..)
|
||||
, Binding(..), Binding'
|
||||
|
||||
, _PatB, _FunB
|
||||
, _VarP, _LitP, _ConP
|
||||
|
||||
-- * Trees That Grow boilerplate
|
||||
-- ** Extension points
|
||||
, IdP, IdP', XRec, UnXRec(..), MapXRec(..)
|
||||
-- *** Decl
|
||||
, XFunD, XTySigD, XInfixD, XDataD, XXDeclD
|
||||
-- *** RlpExpr
|
||||
, XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
|
||||
, XParE, XOAppE, XXRlpExprE
|
||||
-- ** Pattern synonyms
|
||||
-- *** Decl
|
||||
, pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
|
||||
, pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
|
||||
-- *** RlpExpr
|
||||
, pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
|
||||
, pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
|
||||
, pattern XRlpExprE
|
||||
-- *** RlpType
|
||||
, pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
|
||||
, pattern ConT''
|
||||
-- *** Pat
|
||||
, pattern VarP'', pattern LitP'', pattern ConP''
|
||||
-- *** Binding
|
||||
, pattern PatB''
|
||||
( module Rlp.Syntax.Backstage
|
||||
, module Rlp.Syntax.Types
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.String (IsString(..))
|
||||
import Data.Functor.Foldable
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind (Type)
|
||||
import GHC.Generics
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Rlp.Syntax.Backstage
|
||||
import Rlp.Syntax.Types
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 = mkqq parseRlpProgR
|
||||
rlpProg = undefined
|
||||
-- rlpProg = mkqq parseRlpProgR
|
||||
|
||||
rlpExpr :: QuasiQuoter
|
||||
rlpExpr = mkqq parseRlpExprR
|
||||
rlpExpr = undefined
|
||||
-- rlpExpr = mkqq parseRlpExprR
|
||||
|
||||
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
||||
mkq parse = evalAndParse >=> lift where
|
||||
|
||||
@@ -41,6 +41,12 @@ import Rlp.Syntax as Rlp
|
||||
import Rlp.Parse.Types (RlpcPs, PsName)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
desugarRlpProgR = undefined
|
||||
desugarRlpProg = undefined
|
||||
desugarRlpExpr = undefined
|
||||
|
||||
{--
|
||||
|
||||
type Tree a = Either Name (Name, Branch a)
|
||||
|
||||
-- | 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 = 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