RlpcError

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

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
+

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)
+

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)

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
+
 }
 

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)