Compare commits
1 Commits
frontend-p
...
rlp2core
| Author | SHA1 | Date | |
|---|---|---|---|
|
a4c0c3a71a |
@@ -8,8 +8,8 @@ CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
|
||||
|
||||
all: parsers lexers
|
||||
|
||||
parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
|
||||
lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
|
||||
parsers: $(CABAL_BUILD)/Rlp/Parse.hs
|
||||
lexers: $(CABAL_BUILD)/Rlp/Lex.hs
|
||||
|
||||
$(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
|
||||
$(HAPPY) $(HAPPY_OPTS) $< -o $@
|
||||
@@ -17,9 +17,3 @@ $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
|
||||
$(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
|
||||
$(ALEX) $(ALEX_OPTS) $< -o $@
|
||||
|
||||
$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
|
||||
$(HAPPY) $(HAPPY_OPTS) $< -o $@
|
||||
|
||||
$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
|
||||
$(ALEX) $(ALEX_OPTS) $< -o $@
|
||||
|
||||
|
||||
@@ -37,12 +37,14 @@ library
|
||||
, Rlp.Parse.Associate
|
||||
, Rlp.Lex
|
||||
, Rlp.Parse.Types
|
||||
, Rlp.TH
|
||||
|
||||
other-modules: Data.Heap
|
||||
, Data.Pretty
|
||||
, Core.Parse
|
||||
, Core.Lex
|
||||
, Core2Core
|
||||
, Rlp2Core
|
||||
, Control.Monad.Utils
|
||||
|
||||
build-tool-depends: happy:happy, alex:alex
|
||||
@@ -73,9 +75,6 @@ library
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
|
||||
executable rlpc
|
||||
import: warnings
|
||||
main-is: Main.hs
|
||||
|
||||
@@ -26,23 +26,21 @@ import Data.Function ((&))
|
||||
import GM
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
||||
justLexSrc :: String -> Either RlpcError [CoreToken]
|
||||
justLexSrc s = lexCoreR (T.pack s)
|
||||
& fmap (map $ \ (Located _ _ _ t) -> t)
|
||||
& rlpcToEither
|
||||
|
||||
justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justParseSrc :: String -> Either RlpcError Program'
|
||||
justParseSrc s = parse (T.pack s)
|
||||
& rlpcToEither
|
||||
where parse = lexCoreR >=> parseCoreProgR
|
||||
|
||||
justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justTypeCheckSrc :: String -> Either RlpcError Program'
|
||||
justTypeCheckSrc s = typechk (T.pack s)
|
||||
& rlpcToEither
|
||||
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
|
||||
|
||||
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
|
||||
rlpcToEither r = case evalRLPC def r of
|
||||
(Just a, _) -> Right a
|
||||
(Nothing, es) -> Left es
|
||||
rlpcToEither :: RLPC e a -> Either e a
|
||||
rlpcToEither = evalRLPC def >>> fmap fst
|
||||
|
||||
|
||||
@@ -16,9 +16,9 @@ module Compiler.RLPC
|
||||
, RLPCT(..)
|
||||
, RLPCIO
|
||||
, RLPCOptions(RLPCOptions)
|
||||
, IsRlpcError(..)
|
||||
, RlpcError(..)
|
||||
, MsgEnvelope(..)
|
||||
, IsRlpcError(..)
|
||||
, rlpc
|
||||
, addFatal
|
||||
, addWound
|
||||
, MonadErrorful
|
||||
@@ -27,6 +27,9 @@ module Compiler.RLPC
|
||||
, evalRLPCT
|
||||
, evalRLPCIO
|
||||
, evalRLPC
|
||||
, addRlpcWound
|
||||
, addRlpcFatal
|
||||
, liftRlpcErrs
|
||||
, rlpcLogFile
|
||||
, rlpcDebugOpts
|
||||
, rlpcEvaluator
|
||||
@@ -37,7 +40,6 @@ module Compiler.RLPC
|
||||
, flagDDumpOpts
|
||||
, flagDDumpAST
|
||||
, def
|
||||
, liftErrorful
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -49,7 +51,6 @@ import Control.Monad.Errorful
|
||||
import Compiler.RlpcError
|
||||
import Data.Functor.Identity
|
||||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.HashSet (HashSet)
|
||||
@@ -57,44 +58,48 @@ import Data.HashSet qualified as S
|
||||
import Data.Coerce
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH
|
||||
import System.Exit
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
newtype RLPCT m a = RLPCT {
|
||||
runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
|
||||
-- TODO: fancy errors
|
||||
newtype RLPCT e m a = RLPCT {
|
||||
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
|
||||
}
|
||||
deriving (Functor, Applicative, Monad)
|
||||
-- TODO: incorrect ussage of MonadReader. RLPC should have its own
|
||||
-- environment access functions
|
||||
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
|
||||
|
||||
type RLPC = RLPCT Identity
|
||||
deriving instance (MonadIO m) => MonadIO (RLPCT e m)
|
||||
|
||||
type RLPCIO = RLPCT IO
|
||||
instance MonadTrans (RLPCT e) where
|
||||
lift = RLPCT . lift . lift
|
||||
|
||||
instance (MonadState s m) => MonadState s (RLPCT e m) where
|
||||
state = lift . state
|
||||
|
||||
type RLPC e = RLPCT e Identity
|
||||
|
||||
type RLPCIO e = RLPCT e IO
|
||||
|
||||
evalRLPCT :: RLPCOptions
|
||||
-> RLPCT e m a
|
||||
-> m (Either e (a, [e]))
|
||||
evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
|
||||
|
||||
evalRLPC :: RLPCOptions
|
||||
-> RLPC a
|
||||
-> (Maybe a, [MsgEnvelope RlpcError])
|
||||
evalRLPC opt r = runRLPCT r
|
||||
& flip runReaderT opt
|
||||
& runErrorful
|
||||
-> RLPC e a
|
||||
-> Either e (a, [e])
|
||||
evalRLPC o m = coerce $ evalRLPCT o m
|
||||
|
||||
evalRLPCT :: (Monad m)
|
||||
evalRLPCIO :: (Exception e)
|
||||
=> RLPCOptions
|
||||
-> RLPCT m a
|
||||
-> m (Maybe a, [MsgEnvelope RlpcError])
|
||||
evalRLPCT = undefined
|
||||
|
||||
evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
|
||||
evalRLPCIO opt r = do
|
||||
(ma,es) <- evalRLPCT opt r
|
||||
putRlpcErrs es
|
||||
case ma of
|
||||
Just x -> pure x
|
||||
Nothing -> die "Failed, no code compiled."
|
||||
|
||||
putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
|
||||
putRlpcErrs = traverse_ print
|
||||
|
||||
liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
|
||||
liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
|
||||
-> RLPCIO e a
|
||||
-> IO (a, [e])
|
||||
evalRLPCIO o m = do
|
||||
m' <- evalRLPCT o m
|
||||
case m' of
|
||||
-- TODO: errors
|
||||
Left e -> throwIO e
|
||||
Right a -> pure a
|
||||
|
||||
data RLPCOptions = RLPCOptions
|
||||
{ _rlpcLogFile :: Maybe FilePath
|
||||
@@ -108,6 +113,32 @@ data RLPCOptions = RLPCOptions
|
||||
data Evaluator = EvaluatorGM | EvaluatorTI
|
||||
deriving Show
|
||||
|
||||
data Severity = Error
|
||||
| Warning
|
||||
| Debug
|
||||
deriving Show
|
||||
|
||||
-- temporary until we have a new doc building system
|
||||
type ErrorDoc = String
|
||||
|
||||
instance (Monad m) => MonadErrorful e (RLPCT e m) where
|
||||
addWound = RLPCT . lift . addWound
|
||||
addFatal = RLPCT . lift . addFatal
|
||||
|
||||
liftRlpcErrs :: (IsRlpcError e, Monad m)
|
||||
=> RLPCT e m a -> RLPCT RlpcError m a
|
||||
liftRlpcErrs m = RLPCT . ReaderT $ \r ->
|
||||
mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
|
||||
|
||||
addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
|
||||
addRlpcWound = addWound . liftRlpcErr
|
||||
|
||||
addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
|
||||
addRlpcFatal = addWound . liftRlpcErr
|
||||
|
||||
rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
|
||||
rlpc = RLPCT . ReaderT . const
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
instance Default RLPCOptions where
|
||||
|
||||
@@ -1,70 +1,15 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
||||
module Compiler.RlpcError
|
||||
( IsRlpcError(..)
|
||||
, MsgEnvelope(..)
|
||||
, Severity(..)
|
||||
, RlpcError(..)
|
||||
, SrcSpan(..)
|
||||
, msgSpan
|
||||
, msgDiagnostic
|
||||
, msgSeverity
|
||||
, liftRlpcErrors
|
||||
, errorMsg
|
||||
( RlpcError(..)
|
||||
, IsRlpcError(..)
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Monad.Errorful
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import GHC.Exts (IsString(..))
|
||||
import Lens.Micro.Platform
|
||||
import Lens.Micro.Platform.Internal
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data MsgEnvelope e = MsgEnvelope
|
||||
{ _msgSpan :: SrcSpan
|
||||
, _msgDiagnostic :: e
|
||||
, _msgSeverity :: Severity
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
||||
newtype RlpcError = Text [Text]
|
||||
data RlpcError = RlpcErr String -- temp
|
||||
deriving Show
|
||||
|
||||
instance IsString RlpcError where
|
||||
fromString = Text . pure . T.pack
|
||||
|
||||
class IsRlpcError e where
|
||||
liftRlpcError :: e -> RlpcError
|
||||
|
||||
instance IsRlpcError RlpcError where
|
||||
liftRlpcError = id
|
||||
|
||||
data Severity = SevWarning
|
||||
| SevError
|
||||
deriving Show
|
||||
|
||||
data SrcSpan = SrcSpan
|
||||
!Int -- ^ Line
|
||||
!Int -- ^ Column
|
||||
!Int -- ^ Length
|
||||
deriving Show
|
||||
|
||||
makeLenses ''MsgEnvelope
|
||||
|
||||
liftRlpcErrors :: (Functor m, IsRlpcError e)
|
||||
=> ErrorfulT e m a
|
||||
-> ErrorfulT RlpcError m a
|
||||
liftRlpcErrors = mapErrorful liftRlpcError
|
||||
|
||||
instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
|
||||
liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
|
||||
|
||||
errorMsg :: SrcSpan -> e -> MsgEnvelope e
|
||||
errorMsg s e = MsgEnvelope
|
||||
{ _msgSpan = s
|
||||
, _msgDiagnostic = e
|
||||
, _msgSeverity = SevError
|
||||
}
|
||||
class IsRlpcError a where
|
||||
liftRlpcErr :: a -> RlpcError
|
||||
|
||||
|
||||
@@ -1,79 +1,73 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE TupleSections, PatternSynonyms #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Control.Monad.Errorful
|
||||
( ErrorfulT
|
||||
, runErrorfulT
|
||||
, Errorful
|
||||
, runErrorful
|
||||
, mapErrorful
|
||||
, mapErrors
|
||||
, MonadErrorful(..)
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Trans
|
||||
import Data.Functor.Identity
|
||||
import Data.Coerce
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as H
|
||||
import Lens.Micro
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
|
||||
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
|
||||
|
||||
type Errorful e = ErrorfulT e Identity
|
||||
|
||||
pattern Errorful :: (Maybe a, [e]) -> Errorful e a
|
||||
pattern Errorful :: (Either e (a, [e])) -> Errorful e a
|
||||
pattern Errorful a = ErrorfulT (Identity a)
|
||||
|
||||
runErrorful :: Errorful e a -> (Maybe a, [e])
|
||||
runErrorful :: Errorful e a -> Either e (a, [e])
|
||||
runErrorful m = coerce (runErrorfulT m)
|
||||
|
||||
class (Applicative m) => MonadErrorful e m | m -> e where
|
||||
addWound :: e -> m ()
|
||||
addFatal :: e -> m a
|
||||
|
||||
-- not sure if i want to add this yet...
|
||||
-- catchWound :: m a -> (e -> m a) -> m a
|
||||
|
||||
instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
|
||||
addWound e = ErrorfulT $ pure (Just (), [e])
|
||||
addFatal e = ErrorfulT $ pure (Nothing, [e])
|
||||
addWound e = ErrorfulT $ pure . Right $ ((), [e])
|
||||
addFatal e = ErrorfulT $ pure . Left $ e
|
||||
|
||||
instance MonadTrans (ErrorfulT e) where
|
||||
lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
|
||||
lift m = ErrorfulT (Right . (,[]) <$> m)
|
||||
|
||||
instance (MonadIO m) => MonadIO (ErrorfulT e m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance (Functor m) => Functor (ErrorfulT e m) where
|
||||
fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
|
||||
fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
|
||||
|
||||
instance (Applicative m) => Applicative (ErrorfulT e m) where
|
||||
pure a = ErrorfulT . pure $ (Just a, [])
|
||||
pure a = ErrorfulT (pure . Right $ (a, []))
|
||||
|
||||
ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
|
||||
apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
|
||||
apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
|
||||
m <*> a = ErrorfulT (m' `apply` a')
|
||||
where
|
||||
m' = runErrorfulT m
|
||||
a' = runErrorfulT a
|
||||
-- TODO: strict concatenation
|
||||
apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2))
|
||||
|
||||
instance (Monad m) => Monad (ErrorfulT e m) where
|
||||
ErrorfulT m >>= k = ErrorfulT $ do
|
||||
(a,es) <- m
|
||||
case a of
|
||||
Just x -> runErrorfulT (k x)
|
||||
Nothing -> pure (Nothing, es)
|
||||
m' <- m
|
||||
case m' of
|
||||
Right (a,es) -> runErrorfulT (k a)
|
||||
Left e -> pure (Left e)
|
||||
|
||||
mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
|
||||
mapErrorful f (ErrorfulT m) = ErrorfulT $
|
||||
m & mapped . _2 . mapped %~ f
|
||||
|
||||
-- when microlens-pro drops we can write this as
|
||||
-- mapErrorful f = coerced . mapped . _2 . mappd %~ f
|
||||
-- lol
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- daily dose of n^2 instances
|
||||
|
||||
instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
|
||||
addWound = undefined
|
||||
addFatal = undefined
|
||||
mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
|
||||
mapErrors f m = ErrorfulT $ do
|
||||
x <- runErrorfulT m
|
||||
case x of
|
||||
Left e -> pure . Left $ f e
|
||||
Right (a,es) -> pure . Right $ (a, f <$> es)
|
||||
|
||||
|
||||
@@ -15,13 +15,6 @@ import Core.Syntax
|
||||
import Core.TH
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- fac3 = undefined
|
||||
-- sumList = undefined
|
||||
-- constDivZero = undefined
|
||||
-- idCase = undefined
|
||||
|
||||
---
|
||||
|
||||
letrecExample :: Program'
|
||||
letrecExample = [coreProg|
|
||||
pair x y f = f x y;
|
||||
@@ -223,4 +216,3 @@ idCase = [coreProg|
|
||||
-- , ScDef "Cons" [] $ Con 2 2
|
||||
-- ]
|
||||
|
||||
--}
|
||||
|
||||
@@ -3,7 +3,6 @@ Module : Core.HindleyMilner
|
||||
Description : Hindley-Milner type system
|
||||
-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Core.HindleyMilner
|
||||
( Context'
|
||||
, infer
|
||||
@@ -17,17 +16,15 @@ module Core.HindleyMilner
|
||||
----------------------------------------------------------------------------------
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Mtl
|
||||
import Lens.Micro.Platform
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Foldable (traverse_)
|
||||
import Compiler.RLPC
|
||||
import Control.Monad (foldM, void, forM)
|
||||
import Control.Monad (foldM, void)
|
||||
import Control.Monad.Errorful (Errorful, addFatal)
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Utils (mapAccumLM)
|
||||
import Text.Printf
|
||||
import Core.Syntax
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
@@ -51,20 +48,9 @@ data TypeError
|
||||
| TyErrMissingTypeSig Name
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- TODO:
|
||||
instance IsRlpcError TypeError where
|
||||
liftRlpcError = \case
|
||||
-- todo: use anti-parser instead of show
|
||||
TyErrCouldNotUnify t u -> Text
|
||||
[ T.pack $ printf "Could not match type `%s' with `%s'."
|
||||
(show t) (show u)
|
||||
, "Expected: " <> tshow t
|
||||
, "Got: " <> tshow u
|
||||
]
|
||||
TyErrRecursiveType t x -> Text
|
||||
[ T.pack $ printf "recursive type error lol"
|
||||
]
|
||||
|
||||
where tshow = T.pack . show
|
||||
liftRlpcErr = RlpcErr . show
|
||||
|
||||
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
|
||||
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
|
||||
@@ -102,10 +88,10 @@ checkCoreProg p = scDefs
|
||||
where scname = sc ^. _lhs._1
|
||||
|
||||
-- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
|
||||
checkCoreProgR :: Program' -> RLPC Program'
|
||||
checkCoreProgR p = undefined
|
||||
|
||||
{-# WARNING checkCoreProgR "unimpl" #-}
|
||||
checkCoreProgR :: Program' -> RLPC RlpcError Program'
|
||||
checkCoreProgR p = do
|
||||
liftRlpcErrs . rlpc . checkCoreProg $ p
|
||||
pure p
|
||||
|
||||
-- | Infer the type of an expression under some context.
|
||||
--
|
||||
@@ -154,27 +140,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
|
||||
Let NonRec bs e -> do
|
||||
g' <- buildLetContext g bs
|
||||
go g' e
|
||||
Let Rec bs e -> do
|
||||
g' <- buildLetrecContext g bs
|
||||
go g' e
|
||||
|
||||
-- TODO lambda, case
|
||||
|
||||
buildLetrecContext :: Context' -> [Binding']
|
||||
-> StateT ([Constraint], Int) HMError Context'
|
||||
buildLetrecContext g bs = do
|
||||
let f ag (k := _) = do
|
||||
n <- uniqueVar
|
||||
pure ((k,n) : ag)
|
||||
rg <- foldM f g bs
|
||||
let k ag (k := v) = do
|
||||
t <- go rg v
|
||||
pure ((k,t) : ag)
|
||||
foldM k g bs
|
||||
|
||||
-- | augment a context with the inferred types of each binder. the returned
|
||||
-- context is linearly accumulated, meaning that the context used to infer each binder
|
||||
-- will include the inferred types of all previous binder
|
||||
-- TODO letrec, lambda, case
|
||||
|
||||
buildLetContext :: Context' -> [Binding']
|
||||
-> StateT ([Constraint], Int) HMError Context'
|
||||
@@ -252,20 +218,3 @@ subst x t (TyVar y) | x == y = t
|
||||
subst x t (a :-> b) = subst x t a :-> subst x t b
|
||||
subst _ _ e = e
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
demoContext :: Context'
|
||||
demoContext =
|
||||
[ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
|
||||
, ("add", TyInt :-> TyInt :-> TyInt)
|
||||
, ("==", TyInt :-> TyInt :-> TyCon "Bool")
|
||||
, ("True", TyCon "Bool")
|
||||
, ("False", TyCon "Bool")
|
||||
]
|
||||
|
||||
pprintType :: Type -> String
|
||||
pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
|
||||
pprintType TyFun = "(->)"
|
||||
pprintType (TyVar x) = x ^. unpacked
|
||||
pprintType (TyCon t) = t ^. unpacked
|
||||
|
||||
|
||||
@@ -167,19 +167,24 @@ lexWith :: (Text -> CoreToken) -> Lexer
|
||||
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
|
||||
|
||||
-- | The main lexer driver.
|
||||
lexCore :: Text -> RLPC [Located CoreToken]
|
||||
lexCore :: Text -> RLPC SrcError [Located CoreToken]
|
||||
lexCore s = case m of
|
||||
Left e -> error "core lex error"
|
||||
Left e -> addFatal err
|
||||
where err = SrcError
|
||||
{ _errSpan = (0,0,0) -- TODO: location
|
||||
, _errSeverity = Error
|
||||
, _errDiagnostic = SrcErrLexical e
|
||||
}
|
||||
Right ts -> pure ts
|
||||
where
|
||||
m = runAlex s lexStream
|
||||
|
||||
lexCoreR :: Text -> RLPC [Located CoreToken]
|
||||
lexCoreR = lexCore
|
||||
lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
|
||||
lexCoreR = liftRlpcErrs . lexCore
|
||||
|
||||
-- | @lexCore@, but the tokens are stripped of location info. Useful for
|
||||
-- debugging
|
||||
lexCore' :: Text -> RLPC [CoreToken]
|
||||
lexCore' :: Text -> RLPC SrcError [CoreToken]
|
||||
lexCore' s = fmap f <$> lexCore s
|
||||
where f (Located _ _ _ t) = t
|
||||
|
||||
@@ -196,11 +201,11 @@ data ParseError = ParErrLexical String
|
||||
|
||||
-- TODO:
|
||||
instance IsRlpcError SrcError where
|
||||
liftRlpcError = Text . pure . T.pack . show
|
||||
liftRlpcErr = RlpcErr . show
|
||||
|
||||
-- TODO:
|
||||
instance IsRlpcError ParseError where
|
||||
liftRlpcError = Text . pure . T.pack . show
|
||||
liftRlpcErr = RlpcErr . show
|
||||
|
||||
alexEOF :: Alex (Located CoreToken)
|
||||
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
|
||||
|
||||
@@ -10,6 +10,7 @@ module Core.Parse
|
||||
, parseCoreProg
|
||||
, parseCoreProgR
|
||||
, module Core.Lex -- temp convenience
|
||||
, parseTmp
|
||||
, SrcError
|
||||
, Module
|
||||
)
|
||||
@@ -33,7 +34,7 @@ import Data.HashMap.Strict qualified as H
|
||||
%name parseCoreProg StandaloneProgram
|
||||
%tokentype { Located CoreToken }
|
||||
%error { parseError }
|
||||
%monad { RLPC } { happyBind } { happyPure }
|
||||
%monad { RLPC SrcError }
|
||||
|
||||
%token
|
||||
let { Located _ _ _ TokenLet }
|
||||
@@ -98,8 +99,6 @@ ScDefs : ScDef ';' ScDefs { $1 : $3 }
|
||||
|
||||
ScDef :: { ScDef Name }
|
||||
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
|
||||
-- hack to allow constructors to be compiled into scs
|
||||
| Con ParList '=' Expr { ScDef $1 $2 $4 }
|
||||
|
||||
Type :: { Type }
|
||||
Type : Type1 { $1 }
|
||||
@@ -190,23 +189,34 @@ Con : '(' consym ')' { $2 }
|
||||
|
||||
{
|
||||
|
||||
parseError :: [Located CoreToken] -> RLPC a
|
||||
parseError (Located y x l t : _) =
|
||||
error $ show y <> ":" <> show x
|
||||
<> ": parse error at token `" <> show t <> "'"
|
||||
parseError :: [Located CoreToken] -> RLPC SrcError a
|
||||
parseError (Located y x l _ : _) = addFatal err
|
||||
where err = SrcError
|
||||
{ _errSpan = (y,x,l)
|
||||
, _errSeverity = Error
|
||||
, _errDiagnostic = SrcErrParse
|
||||
}
|
||||
|
||||
{-# WARNING parseError "unimpl" #-}
|
||||
parseTmp :: IO (Module Name)
|
||||
parseTmp = do
|
||||
s <- TIO.readFile "/tmp/t.hs"
|
||||
case parse s of
|
||||
Left e -> error (show e)
|
||||
Right (ts,_) -> pure ts
|
||||
where
|
||||
parse = evalRLPC def . (lexCore >=> parseCore)
|
||||
|
||||
exprPragma :: [String] -> RLPC (Expr Name)
|
||||
exprPragma ("AST" : e) = undefined
|
||||
exprPragma _ = undefined
|
||||
exprPragma :: [String] -> RLPC SrcError (Expr Name)
|
||||
exprPragma ("AST" : e) = astPragma e
|
||||
exprPragma _ = addFatal err
|
||||
where err = SrcError
|
||||
{ _errSpan = (0,0,0) -- TODO: span
|
||||
, _errSeverity = Warning
|
||||
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
|
||||
}
|
||||
|
||||
{-# WARNING exprPragma "unimpl" #-}
|
||||
|
||||
astPragma :: [String] -> RLPC (Expr Name)
|
||||
astPragma _ = undefined
|
||||
|
||||
{-# WARNING astPragma "unimpl" #-}
|
||||
astPragma :: [String] -> RLPC SrcError (Expr Name)
|
||||
astPragma = pure . read . unwords
|
||||
|
||||
insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
|
||||
insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
|
||||
@@ -220,14 +230,8 @@ insScDef sc = programScDefs %~ (sc:)
|
||||
singletonScDef :: (Hashable b) => ScDef b -> Program b
|
||||
singletonScDef sc = insScDef sc mempty
|
||||
|
||||
parseCoreProgR :: [Located CoreToken] -> RLPC Program'
|
||||
parseCoreProgR = parseCoreProg
|
||||
|
||||
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
|
||||
happyBind m k = m >>= k
|
||||
|
||||
happyPure :: a -> RLPC a
|
||||
happyPure a = pure a
|
||||
parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
|
||||
parseCoreProgR = liftRlpcErrs . parseCoreProg
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -6,6 +6,7 @@ module Core.TH
|
||||
( coreExpr
|
||||
, coreProg
|
||||
, coreProgT
|
||||
, core
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -13,38 +14,74 @@ import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax hiding (Module)
|
||||
import Language.Haskell.TH.Quote
|
||||
import Control.Monad ((>=>))
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Arrow ((>>>))
|
||||
import Compiler.RLPC
|
||||
import Data.Default.Class (def)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Core.Parse
|
||||
import Core.Lex
|
||||
import Core.Syntax
|
||||
import Core.HindleyMilner (checkCoreProgR)
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
coreProg :: QuasiQuoter
|
||||
coreProg = mkqq $ lexCoreR >=> parseCoreProgR
|
||||
-- TODO: write in terms of a String -> QuasiQuoter
|
||||
|
||||
coreExpr :: QuasiQuoter
|
||||
coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
|
||||
|
||||
-- | Type-checked @coreProg@
|
||||
coreProgT :: QuasiQuoter
|
||||
coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
|
||||
|
||||
mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
|
||||
mkqq p = QuasiQuoter
|
||||
{ quoteExp = mkq p
|
||||
core :: QuasiQuoter
|
||||
core = QuasiQuoter
|
||||
{ quoteExp = qCore
|
||||
, quotePat = error "core quasiquotes may only be used in expressions"
|
||||
, quoteType = error "core quasiquotes may only be used in expressions"
|
||||
, quoteDec = error "core quasiquotes may only be used in expressions"
|
||||
}
|
||||
|
||||
mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
|
||||
mkq parse s = case evalRLPC def (parse $ T.pack s) of
|
||||
(Just a, _) -> lift a
|
||||
(Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"
|
||||
coreProg :: QuasiQuoter
|
||||
coreProg = QuasiQuoter
|
||||
{ quoteExp = qCoreProg
|
||||
, quotePat = error "core quasiquotes may only be used in expressions"
|
||||
, quoteType = error "core quasiquotes may only be used in expressions"
|
||||
, quoteDec = error "core quasiquotes may only be used in expressions"
|
||||
}
|
||||
|
||||
coreExpr :: QuasiQuoter
|
||||
coreExpr = QuasiQuoter
|
||||
{ quoteExp = qCoreExpr
|
||||
, quotePat = error "core quasiquotes may only be used in expressions"
|
||||
, quoteType = error "core quasiquotes may only be used in expressions"
|
||||
, quoteDec = error "core quasiquotes may only be used in expressions"
|
||||
}
|
||||
|
||||
-- | Type-checked @coreProg@
|
||||
coreProgT :: QuasiQuoter
|
||||
coreProgT = QuasiQuoter
|
||||
{ quoteExp = qCoreProgT
|
||||
, quotePat = error "core quasiquotes may only be used in expressions"
|
||||
, quoteType = error "core quasiquotes may only be used in expressions"
|
||||
, quoteDec = error "core quasiquotes may only be used in expressions"
|
||||
}
|
||||
|
||||
qCore :: String -> Q Exp
|
||||
qCore s = case parse (T.pack s) of
|
||||
Left e -> error (show e)
|
||||
Right (m,ts) -> lift m
|
||||
where
|
||||
parse = evalRLPC def . (lexCore >=> parseCore)
|
||||
|
||||
qCoreExpr :: String -> Q Exp
|
||||
qCoreExpr s = case parseExpr (T.pack s) of
|
||||
Left e -> error (show e)
|
||||
Right (m,ts) -> lift m
|
||||
where
|
||||
parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
|
||||
|
||||
qCoreProg :: String -> Q Exp
|
||||
qCoreProg s = case parse (T.pack s) of
|
||||
Left e -> error (show e)
|
||||
Right (m,ts) -> lift m
|
||||
where
|
||||
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
|
||||
|
||||
qCoreProgT :: String -> Q Exp
|
||||
qCoreProgT s = case parse (T.pack s) of
|
||||
Left e -> error (show e)
|
||||
Right (m,_) -> lift m
|
||||
where
|
||||
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)
|
||||
|
||||
|
||||
@@ -7,14 +7,14 @@ module Rlp.Lex
|
||||
, RlpToken(..)
|
||||
, Located(..)
|
||||
, lexToken
|
||||
, lexStream
|
||||
, lexDebug
|
||||
, lexCont
|
||||
, execP
|
||||
, execP'
|
||||
)
|
||||
where
|
||||
import Codec.Binary.UTF8.String (encodeChar)
|
||||
import Control.Monad
|
||||
import Control.Monad.Errorful
|
||||
import Core.Syntax (Name)
|
||||
import Data.Functor.Identity
|
||||
import Data.Char (digitToInt)
|
||||
@@ -54,10 +54,9 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
|
||||
|
||||
@reservedname =
|
||||
case|data|do|import|in|let|letrec|module|of|where
|
||||
|infixr|infixl|infix
|
||||
|
||||
@reservedop =
|
||||
"=" | \\ | "->" | "|"
|
||||
"=" | \\ | "->" | "|" | "::"
|
||||
|
||||
rlp :-
|
||||
|
||||
@@ -126,9 +125,6 @@ lexReservedName = \case
|
||||
"of" -> TokenOf
|
||||
"let" -> TokenLet
|
||||
"in" -> TokenIn
|
||||
"infix" -> TokenInfix
|
||||
"infixl" -> TokenInfixL
|
||||
"infixr" -> TokenInfixR
|
||||
|
||||
lexReservedOp :: Text -> RlpToken
|
||||
lexReservedOp = \case
|
||||
@@ -209,6 +205,13 @@ alexEOF = do
|
||||
inp <- getInput
|
||||
pure (Located undefined TokenEOF)
|
||||
|
||||
execP :: P a -> ParseState -> Maybe a
|
||||
execP p st = runP p st & snd
|
||||
|
||||
execP' :: P a -> Text -> Maybe a
|
||||
execP' p s = execP p st where
|
||||
st = initParseState s
|
||||
|
||||
initParseState :: Text -> ParseState
|
||||
initParseState s = ParseState
|
||||
{ _psLayoutStack = []
|
||||
@@ -227,10 +230,6 @@ initAlexInput s = AlexInput
|
||||
, _aiPos = (1,1)
|
||||
}
|
||||
|
||||
runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||
runP' p s = runP p st where
|
||||
st = initParseState s
|
||||
|
||||
lexToken :: P (Located RlpToken)
|
||||
lexToken = do
|
||||
inp <- getInput
|
||||
@@ -245,7 +244,6 @@ lexToken = do
|
||||
AlexToken inp' l act -> do
|
||||
psInput .= inp'
|
||||
act inp l
|
||||
AlexError inp' -> addFatalHere 1 RlpParErrLexical
|
||||
|
||||
lexCont :: (Located RlpToken -> P a) -> P a
|
||||
lexCont = (lexToken >>=)
|
||||
@@ -264,7 +262,7 @@ lexDebug k = do
|
||||
k t
|
||||
|
||||
lexTest :: Text -> Maybe [RlpToken]
|
||||
lexTest s = runP' lexStream s ^. _3
|
||||
lexTest s = execP' lexStream s
|
||||
|
||||
indentLevel :: P Int
|
||||
indentLevel = do
|
||||
|
||||
@@ -2,9 +2,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Rlp.Parse
|
||||
( parseRlpProg
|
||||
, execP
|
||||
, execP'
|
||||
)
|
||||
where
|
||||
import Compiler.RlpcError
|
||||
import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
@@ -15,7 +16,6 @@ import Lens.Micro.Platform ()
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
import Data.Text qualified as T
|
||||
}
|
||||
|
||||
%name parseRlpProg StandaloneProgram
|
||||
@@ -32,6 +32,7 @@ import Data.Text qualified as T
|
||||
varsym { Located _ (TokenVarSym $$) }
|
||||
data { Located _ TokenData }
|
||||
litint { Located _ (TokenLitInt $$) }
|
||||
'::' { Located _ TokenHasType }
|
||||
'=' { Located _ TokenEquals }
|
||||
'|' { Located _ TokenPipe }
|
||||
';' { Located _ TokenSemicolon }
|
||||
@@ -78,9 +79,15 @@ VS : ';' { $1 }
|
||||
|
||||
Decl :: { PartialDecl' }
|
||||
: FunDecl { $1 }
|
||||
| TySigDecl { $1 }
|
||||
| DataDecl { $1 }
|
||||
| InfixDecl { $1 }
|
||||
|
||||
-- TODO: multiple vars
|
||||
|
||||
TySigDecl :: { PartialDecl' }
|
||||
: Var '::' Type { TySigD [$1] $3 }
|
||||
|
||||
InfixDecl :: { PartialDecl' }
|
||||
: InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
|
||||
|
||||
@@ -163,19 +170,15 @@ mkProgram ds = do
|
||||
pure $ RlpProgram (associate pt <$> ds)
|
||||
|
||||
parseError :: Located RlpToken -> P a
|
||||
parseError (Located ((l,c),s) t) = addFatal $
|
||||
errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
|
||||
parseError = error . show
|
||||
|
||||
mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
|
||||
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
|
||||
Just o -> error "(TODO: non-fatal) duplicate inix decls"
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pure $ InfixD a p n
|
||||
|
||||
}
|
||||
|
||||
@@ -1,47 +1,11 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Rlp.Parse.Types
|
||||
( LexerAction
|
||||
, MsgEnvelope(..)
|
||||
, RlpcError(..)
|
||||
, AlexInput(..)
|
||||
, Position(..)
|
||||
, RlpToken(..)
|
||||
, P(..)
|
||||
, ParseState(..)
|
||||
, psLayoutStack
|
||||
, psLexState
|
||||
, psInput
|
||||
, psOpTable
|
||||
, Layout(..)
|
||||
, Located(..)
|
||||
, OpTable
|
||||
, OpInfo
|
||||
, RlpParseError(..)
|
||||
, PartialDecl'
|
||||
, Partial(..)
|
||||
, pL, pR
|
||||
, PartialE
|
||||
, pattern WithInfo
|
||||
, opInfoOrDef
|
||||
, PartialExpr'
|
||||
, aiPrevChar
|
||||
, aiSource
|
||||
, aiBytes
|
||||
, aiPos
|
||||
, addFatal
|
||||
, addWound
|
||||
, addFatalHere
|
||||
, addWoundHere
|
||||
)
|
||||
where
|
||||
module Rlp.Parse.Types where
|
||||
--------------------------------------------------------------------------------
|
||||
import Core.Syntax (Name)
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Errorful
|
||||
import Compiler.RlpcError
|
||||
import Control.Monad.State.Class
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe
|
||||
import Data.Fix
|
||||
@@ -70,12 +34,6 @@ type Position =
|
||||
, Int -- column
|
||||
)
|
||||
|
||||
posLine :: Lens' Position Int
|
||||
posLine = _1
|
||||
|
||||
posColumn :: Lens' Position Int
|
||||
posColumn = _2
|
||||
|
||||
data RlpToken
|
||||
-- literals
|
||||
= TokenLitInt Int
|
||||
@@ -113,34 +71,24 @@ data RlpToken
|
||||
| TokenEOF
|
||||
deriving (Show)
|
||||
|
||||
newtype P a = P {
|
||||
runP :: ParseState
|
||||
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||
}
|
||||
newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
|
||||
deriving (Functor)
|
||||
|
||||
instance Applicative P where
|
||||
pure a = P $ \st -> (st, [], pure a)
|
||||
pure a = P $ \st -> (st,Just a)
|
||||
liftA2 = liftM2
|
||||
|
||||
instance Monad P where
|
||||
p >>= k = P $ \st ->
|
||||
let (st',es,ma) = runP p st
|
||||
in case ma of
|
||||
Just a -> runP (k a) st'
|
||||
& _2 %~ (es<>)
|
||||
Nothing -> (st',es,Nothing)
|
||||
|
||||
{-# INLINE (>>=) #-}
|
||||
let (st',a) = runP p st
|
||||
in case a of
|
||||
Just x -> runP (k x) st'
|
||||
Nothing -> (st', Nothing)
|
||||
|
||||
instance MonadState ParseState P where
|
||||
state f = P $ \st ->
|
||||
let (a,st') = f st
|
||||
in (st', [], Just a)
|
||||
|
||||
instance MonadErrorful (MsgEnvelope RlpParseError) P where
|
||||
addWound e = P $ \st -> (st, [e], Just ())
|
||||
addFatal e = P $ \st -> (st, [e], Nothing)
|
||||
in (st', Just a)
|
||||
|
||||
data ParseState = ParseState
|
||||
{ _psLayoutStack :: [Layout]
|
||||
@@ -163,14 +111,11 @@ type OpInfo = (Assoc, Int)
|
||||
-- data WithLocation a = WithLocation [String] a
|
||||
|
||||
data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
|
||||
| RlpParErrDuplicateInfixD Name
|
||||
| RlpParErrLexical
|
||||
| RlpParErrUnexpectedToken
|
||||
| RlpParErrDuplicateInfixD
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance IsRlpcError RlpParseError where
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- absolute psycho shit (partial ASTs)
|
||||
|
||||
type PartialDecl' = Decl (Const PartialExpr') Name
|
||||
@@ -216,27 +161,3 @@ type PartialExpr' = Fix Partial
|
||||
makeLenses ''AlexInput
|
||||
makeLenses ''ParseState
|
||||
|
||||
addWoundHere :: Int -> RlpParseError -> P ()
|
||||
addWoundHere l e = P $ \st ->
|
||||
let e' = MsgEnvelope
|
||||
{ _msgSpan = let pos = psInput . aiPos
|
||||
in SrcSpan (st ^. pos . posLine)
|
||||
(st ^. pos . posColumn)
|
||||
l
|
||||
, _msgDiagnostic = e
|
||||
, _msgSeverity = SevError
|
||||
}
|
||||
in (st, [e'], Just ())
|
||||
|
||||
addFatalHere :: Int -> RlpParseError -> P a
|
||||
addFatalHere l e = P $ \st ->
|
||||
let e' = MsgEnvelope
|
||||
{ _msgSpan = let pos = psInput . aiPos
|
||||
in SrcSpan (st ^. pos . posLine)
|
||||
(st ^. pos . posColumn)
|
||||
l
|
||||
, _msgDiagnostic = e
|
||||
, _msgSeverity = SevError
|
||||
}
|
||||
in (st, [e'], Nothing)
|
||||
|
||||
|
||||
@@ -45,6 +45,7 @@ import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.Functor.Classes
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Core.Syntax hiding (Lit)
|
||||
import Core (HasRHS(..), HasLHS(..))
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -55,7 +56,7 @@ data RlpModule b = RlpModule
|
||||
}
|
||||
|
||||
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
type RlpProgram' = RlpProgram Name
|
||||
|
||||
@@ -70,19 +71,19 @@ data Decl e b = FunD VarId [Pat b] (e b) (Maybe (Where b))
|
||||
| TySigD [VarId] Type
|
||||
| DataD ConId [Name] [ConAlt]
|
||||
| InfixD Assoc Int Name
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
type Decl' e = Decl e Name
|
||||
|
||||
data Assoc = InfixL
|
||||
| InfixR
|
||||
| Infix
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
data ConAlt = ConAlt ConId [Type]
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
data RlpExpr b = LetE Rec [Bind b] (RlpExpr b)
|
||||
data RlpExpr b = LetE [Bind b] (RlpExpr b)
|
||||
| VarE VarId
|
||||
| ConE ConId
|
||||
| LamE [Pat b] (RlpExpr b)
|
||||
@@ -90,7 +91,7 @@ data RlpExpr b = LetE Rec [Bind b] (RlpExpr b)
|
||||
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b)
|
||||
| AppE (RlpExpr b) (RlpExpr b)
|
||||
| LitE (Lit b)
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
type RlpExpr' = RlpExpr Name
|
||||
|
||||
@@ -99,15 +100,15 @@ type Where' = [Bind Name]
|
||||
|
||||
-- do we want guards?
|
||||
data Alt b = AltA (Pat b) (RlpExpr b)
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
data Bind b = PatB (Pat b) (RlpExpr b)
|
||||
| FunB VarId [Pat b] (RlpExpr b)
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
data VarId = NameVar Text
|
||||
| SymVar Text
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
instance IsString VarId where
|
||||
-- TODO: use symvar if it's an operator
|
||||
@@ -115,19 +116,19 @@ instance IsString VarId where
|
||||
|
||||
data ConId = NameCon Text
|
||||
| SymCon Text
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
data Pat b = VarP VarId
|
||||
| LitP (Lit b)
|
||||
| ConP ConId [Pat b]
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
type Pat' = Pat Name
|
||||
|
||||
data Lit b = IntL Int
|
||||
| CharL Char
|
||||
| ListL [RlpExpr b]
|
||||
deriving Show
|
||||
deriving (Show, Lift)
|
||||
|
||||
type Lit' = Lit Name
|
||||
|
||||
@@ -150,7 +151,7 @@ type RlpExprF' = RlpExprF Name
|
||||
-- society if derivable Show1
|
||||
instance (Show b) => Show1 (RlpExprF b) where
|
||||
liftShowsPrec sp _ p m = case m of
|
||||
(LetEF r bs e) -> showsTernaryWith showsPrec showsPrec sp "LetEF" p r bs e
|
||||
(LetEF bs e) -> showsBinaryWith showsPrec sp "LetEF" p bs e
|
||||
(VarEF n) -> showsUnaryWith showsPrec "VarEF" p n
|
||||
(ConEF n) -> showsUnaryWith showsPrec "ConEF" p n
|
||||
(LamEF bs e) -> showsBinaryWith showsPrec sp "LamEF" p bs e
|
||||
|
||||
30
src/Rlp/TH.hs
Normal file
30
src/Rlp/TH.hs
Normal file
@@ -0,0 +1,30 @@
|
||||
module Rlp.TH
|
||||
( rlpProg
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax hiding (Module)
|
||||
import Language.Haskell.TH.Quote
|
||||
import Control.Monad ((>=>))
|
||||
import Compiler.RLPC
|
||||
import Data.Default.Class (def)
|
||||
import Data.Text qualified as T
|
||||
import Rlp.Parse
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
rlpProg :: QuasiQuoter
|
||||
rlpProg = QuasiQuoter
|
||||
{ quoteExp = qRlpProg
|
||||
, quotePat = error "rlp quasiquotes may only be used in expressions"
|
||||
, quoteType = error "rlp quasiquotes may only be used in expressions"
|
||||
, quoteDec = error "rlp quasiquotes may only be used in expressions"
|
||||
}
|
||||
|
||||
qRlpProg :: String -> Q Exp
|
||||
qRlpProg s = case parse (T.pack s) of
|
||||
Nothing -> error "error lol iddfk"
|
||||
Just a -> lift a
|
||||
where
|
||||
parse = execP' parseRlpProg
|
||||
|
||||
44
src/Rlp2Core.hs
Normal file
44
src/Rlp2Core.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Rlp2Core
|
||||
( rlp2core
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Core.Syntax as Core
|
||||
import Rlp.Syntax as Rlp
|
||||
import Data.Foldable
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Control.Monad.State
|
||||
import Lens.Micro.Platform
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
rlp2core :: RlpProgram' -> Program'
|
||||
rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init
|
||||
where
|
||||
init = Program
|
||||
{ _programScDefs = mempty
|
||||
, _programTypeSigs = mempty
|
||||
}
|
||||
|
||||
type GenCoreProg b = State (Program b)
|
||||
|
||||
type GenCoreProg' = GenCoreProg Name
|
||||
|
||||
emitTypeSig :: Name -> Type -> GenCoreProg' ()
|
||||
emitTypeSig b t = do
|
||||
let tl :: Lens' Program' (Maybe Type)
|
||||
tl = programTypeSigs . at b
|
||||
tl <~ (use tl >>= \case
|
||||
-- TODO: non-fatal error
|
||||
Just o -> error "(TODO: non-fatal) duplicate type sigs"
|
||||
Nothing -> pure (Just t)
|
||||
)
|
||||
|
||||
decl2core :: Decl' RlpExpr -> GenCoreProg' ()
|
||||
|
||||
decl2core (DataD n as cs) = undefined
|
||||
|
||||
decl2core (TySigD vs t) = mkSig `traverse_` vs where
|
||||
mkSig :: VarId -> GenCoreProg' ()
|
||||
mkSig (NameVar n) = emitTypeSig n t
|
||||
|
||||
@@ -38,13 +38,9 @@ spec = do
|
||||
let e = [coreExpr|3|]
|
||||
in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
|
||||
|
||||
infer' :: Context' -> Expr' -> Either [TypeError] Type
|
||||
infer' g e = case runErrorful $ infer g e of
|
||||
(Just t, _) -> Right t
|
||||
(Nothing, es) -> Left es
|
||||
infer' :: Context' -> Expr' -> Either TypeError Type
|
||||
infer' g e = fmap fst . runErrorful $ infer g e
|
||||
|
||||
check' :: Context' -> Type -> Expr' -> Either [TypeError] ()
|
||||
check' g t e = case runErrorful $ check g t e of
|
||||
(Just t, _) -> Right ()
|
||||
(Nothing, es) -> Left es
|
||||
check' :: Context' -> Type -> Expr' -> Either TypeError ()
|
||||
check' g t e = fmap fst . runErrorful $ check g t e
|
||||
|
||||
|
||||
0
tst/Rlp/Parse/DeclsSpec.hs
Normal file
0
tst/Rlp/Parse/DeclsSpec.hs
Normal file
Reference in New Issue
Block a user