diff --git a/rlp.cabal b/rlp.cabal index 990386f..34a5c00 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -22,6 +22,7 @@ library , TI , GM , Compiler.RLPC + , Compiler.RlpcError , Core.Syntax , Core.Examples , Core.Utils diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 9cd1454..e1e6778 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -16,6 +16,7 @@ module Compiler.RLPC , RLPCT , RLPCIO , RLPCOptions(RLPCOptions) + , RlpcError(..) , addFatal , addWound , MonadErrorful @@ -24,6 +25,9 @@ module Compiler.RLPC , evalRLPCT , evalRLPCIO , evalRLPC + , addRlpcWound + , addRlpcFatal + , liftRlpcErrs , rlpcLogFile , rlpcDebugOpts , rlpcEvaluator @@ -42,6 +46,7 @@ import Control.Exception import Control.Monad.Reader import Control.Monad.State (MonadState(state)) import Control.Monad.Errorful +import Compiler.RlpcError import Data.Functor.Identity import Data.Default.Class import GHC.Generics (Generic) @@ -115,13 +120,21 @@ data Severity = Error -- temporary until we have a new doc building system type ErrorDoc = String -class Diagnostic e where - errorDoc :: e -> ErrorDoc - 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 + ---------------------------------------------------------------------------------- instance Default RLPCOptions where diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs new file mode 100644 index 0000000..581d301 --- /dev/null +++ b/src/Compiler/RlpcError.hs @@ -0,0 +1,15 @@ +module Compiler.RlpcError + ( RlpcError(..) + , IsRlpcError(..) + ) + where +---------------------------------------------------------------------------------- +import Control.Monad.Errorful +---------------------------------------------------------------------------------- + +data RlpcError = RlpcErr String -- temp + deriving Show + +class IsRlpcError a where + liftRlpcErr :: a -> RlpcError + diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index bcfd4a3..789a4ad 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -6,6 +6,7 @@ module Control.Monad.Errorful , runErrorfulT , Errorful , runErrorful + , mapErrors , MonadErrorful(..) ) where @@ -63,3 +64,10 @@ instance (Monad m) => Monad (ErrorfulT e m) where Right (a,es) -> runErrorfulT (k a) Left e -> pure (Left e) +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) + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 0cf9795..341b51b 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -6,6 +6,7 @@ Description : Lexical analysis for the core language {-# LANGUAGE OverloadedStrings #-} module Core.Lex ( lexCore + , lexCoreR , lexCore' , CoreToken(..) , SrcError(..) @@ -21,6 +22,7 @@ import Data.Text qualified as T import Data.String (IsString(..)) import Core.Syntax import Compiler.RLPC +import Compiler.RlpcError import Lens.Micro import Lens.Micro.TH } @@ -177,6 +179,9 @@ lexCore s = case m of where m = runAlex s lexStream +lexCoreR :: Text -> RLPC RlpcError [Located CoreToken] +lexCoreR = liftRlpcErrs . lexCore + -- | @lexCore@, but the tokens are stripped of location info. Useful for -- debugging lexCore' :: Text -> RLPC SrcError [CoreToken] @@ -194,6 +199,14 @@ data ParseError = ParErrLexical String | ParErrParse deriving Show +-- TODO: +instance IsRlpcError SrcError where + liftRlpcErr = RlpcErr . show + +-- TODO: +instance IsRlpcError ParseError where + liftRlpcErr = RlpcErr . show + alexEOF :: Alex (Located CoreToken) alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> Right (st, Located y x 0 TokenEOF) diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 0133d15..11e91be 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -8,6 +8,7 @@ module Core.Parse ( parseCore , parseCoreExpr , parseCoreProg + , parseCoreProgR , module Core.Lex -- temp convenience , parseTmp , SrcError @@ -229,5 +230,8 @@ insScDef sc = programScDefs %~ (sc:) singletonScDef :: (Hashable b) => ScDef b -> Program b singletonScDef sc = insScDef sc mempty +parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program' +parseCoreProgR = liftRlpcErrs . parseCoreProg + } diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 72ec901..063d4fe 100644 --- a/src/Core/TH.hs +++ b/src/Core/TH.hs @@ -63,5 +63,5 @@ qCoreProg s = case parseProg (T.pack s) of Left e -> error (show e) Right (m,ts) -> lift m where - parseProg = evalRLPC def . (lexCore >=> parseCoreProg) + parseProg = evalRLPC def . (lexCoreR >=> parseCoreProgR)