From 46f0393a037690d70a4444474602d2d75090b88c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 1 Feb 2024 10:37:51 -0700 Subject: [PATCH] *R functions --- src/Compiler/RLPC.hs | 61 +++++++++++++++++++---------------- src/Control/Monad/Errorful.hs | 7 ++-- src/Core/HindleyMilner.hs | 2 +- src/Core/Lex.x | 8 +++-- src/Core/Parse.y | 8 +++-- 5 files changed, 52 insertions(+), 34 deletions(-) diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index a7919d6..f928f5d 100644 --- a/src/Compiler/RLPC.hs +++ b/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(..) - , RLPCIO - , RLPCOptions(RLPCOptions) - , IsRlpcError(..) - , RlpcError(..) - , MsgEnvelope(..) - , addFatal - , addWound - , MonadErrorful - , Severity(..) - , Language(..) - , Evaluator(..) - , evalRLPCT - , evalRLPCIO - , evalRLPC - , rlpcLogFile - , rlpcDFlags - , rlpcEvaluator - , rlpcInputFiles - , DebugFlag(..) - , whenDFlag - , whenFFlag - , def - , liftErrorful + ( + -- * Rlpc Monad transformer + RLPCT(RLPCT), + -- ** Special cases + RLPC, RLPCIO + -- ** Running + , runRLPCT + , evalRLPCT, evalRLPCIO, evalRLPC + -- * Rlpc options + , Language(..), Evaluator(..) + , DebugFlag(..), CompilerFlag(..) + -- ** Lenses + , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage + -- * Misc. MTL-style functions + , liftErrorful, hoistRlpcT + -- * Misc. Rlpc Monad -related types + , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..) + , MsgEnvelope(..), Severity(..) + , whenDFlag, whenFFlag + -- * Convenient re-exports + , addFatal, addWound, def ) 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) - => RLPCOptions +evalRLPCT :: 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 diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index f767b99..f24042b 100644 --- a/src/Control/Monad/Errorful.hs +++ b/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) diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index cf0dace..7dcc4c6 100644 --- a/src/Core/HindleyMilner.hs +++ b/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" #-} diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 99a67b1..dba29c9 100644 --- a/src/Core/Lex.x +++ b/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 = lexCore +lexCoreR :: forall m. (Applicative m) => Text -> RLPCT m [Located CoreToken] +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 diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 7dbb6b5..5f4dc38 100644 --- a/src/Core/Parse.y +++ b/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 = parseCoreProg +parseCoreProgR :: forall m. (Applicative m) => [Located CoreToken] -> RLPCT m Program' +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