src/Compiler/RLPC.hs

@@ -11,32 +11,29 @@ errors and the family of RLPC monads.
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
+{-# LANGUAGE BlockArguments #-}
 module Compiler.RLPC
-    ( RLPC
+    (
-    , RLPCT(..)
+    -- * Rlpc Monad transformer
-    , RLPCIO
+      RLPCT(RLPCT),
-    , RLPCOptions(RLPCOptions)
+    -- ** Special cases
-    , IsRlpcError(..)
+      RLPC, RLPCIO
-    , RlpcError(..)
+    -- ** Running
-    , MsgEnvelope(..)
+    , runRLPCT
-    , addFatal
+    , evalRLPCT, evalRLPCIO, evalRLPC
-    , addWound
+    -- * Rlpc options
-    , MonadErrorful
+    , Language(..), Evaluator(..)
-    , Severity(..)
+    , DebugFlag(..), CompilerFlag(..)
-    , Language(..)
+    -- ** Lenses
-    , Evaluator(..)
+    , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
-    , evalRLPCT
+    -- * Misc. MTL-style functions
-    , evalRLPCIO
+    , liftErrorful, hoistRlpcT
-    , evalRLPC
+    -- * Misc. Rlpc Monad -related types
-    , rlpcLogFile
+    , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
-    , rlpcDFlags  
+    , MsgEnvelope(..), Severity(..)
-    , rlpcEvaluator
+    , whenDFlag, whenFFlag
-    , rlpcInputFiles
+    -- * Convenient re-exports
-    , DebugFlag(..)
+    , addFatal, addWound, def
-    , whenDFlag
-    , whenFFlag
-    , def
-    , liftErrorful
     )
     where
 ----------------------------------------------------------------------------------
@@ -71,6 +68,12 @@ newtype RLPCT m a = RLPCT {
     }
     deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
+rlpc :: (IsRlpcError e, Monad m)
+     => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
+     -> RLPCT m a
+rlpc f = RLPCT . ReaderT $ \opt ->
+    ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
+
 type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
@@ -84,8 +87,7 @@ evalRLPC opt r = runRLPCT r
                & flip runReaderT opt
                & runErrorful
 
-evalRLPCT :: (Monad m)
+evalRLPCT :: RLPCOptions
-          => RLPCOptions
           -> RLPCT m a
           -> m (Maybe a, [MsgEnvelope RlpcError])
 evalRLPCT opt r = runRLPCT r
@@ -132,6 +134,11 @@ prettyRlpcErr msg = header
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
+hoistRlpcT :: (forall a. m a -> n a)
+         -> RLPCT m a -> RLPCT n a
+hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
+    ErrorfulT $ f $ evalRLPCT opt rma
+
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
     , _rlpcDFlags      :: HashSet DebugFlag

src/Control/Monad/Errorful.hs

@@ -1,11 +1,11 @@
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TupleSections, PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
     ( ErrorfulT(..)
     , Errorful
     , pattern Errorful
+    , errorful
     , runErrorful
     , mapErrorful
     , MonadErrorful(..)
@@ -28,6 +28,9 @@ type Errorful e = ErrorfulT e Identity
 pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
+errorful :: (Applicative m) => (Maybe a, [e]) -> ErrorfulT e m a
+errorful = ErrorfulT . pure
+
 runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 

src/Core/HindleyMilner.hs

@@ -105,7 +105,7 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
+checkCoreProgR :: (Applicative m) => Program' -> RLPCT m Program'
 checkCoreProgR p = undefined
 
 {-# WARNING checkCoreProgR "unimpl" #-}

src/Core/Lex.x

@@ -20,6 +20,7 @@ import Debug.Trace
 import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.String          (IsString(..))
+import Data.Functor.Identity
 import Core.Syntax
 import Compiler.RLPC
 -- TODO: unify Located definitions
@@ -180,8 +181,11 @@ lexCore s = case m of
     where
         m = runAlex s lexStream
 
-lexCoreR :: Text -> RLPC [Located CoreToken]
+lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken]
-lexCoreR = lexCore
+lexCoreR = hoistRlpcT generalise . lexCore
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging

src/Core/Parse.y

@@ -17,6 +17,7 @@ module Core.Parse
 
 import Control.Monad        ((>=>))
 import Data.Foldable        (foldl')
+import Data.Functor.Identity
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
@@ -224,8 +225,11 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC Program'
+parseCoreProgR :: forall m. (Applicative m) => [Located CoreToken] -> RLPCT m Program'
-parseCoreProgR = parseCoreProg
+parseCoreProgR = hoistRlpcT generalise . parseCoreProg
+    where
+        generalise :: forall a. Identity a -> m a
+        generalise (Identity a) = pure a
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k