{-| Module : Prosidy.Compile.Run Description : Interpretation of compilation rules. Copyright : ©2020 James Alexander Feldman-Crough License : MPL-2.0 Maintainer : alex@fldcr.com -} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} module Prosidy.Compile.Run (run, runM) where import Lens.Micro import Prosidy.Compile.Core import Prosidy.Compile.Error import Control.Monad.Trans ( MonadIO(..) , MonadTrans(..) ) import Control.Monad.Except ( ExceptT(..) ) import Data.Functor.Identity ( Identity(..) ) import qualified Prosidy as P ------------------------------------------------------------------------------- -- | Run a 'Rule' against an input, returning a parse result. run :: IsError e => RuleT i e Identity a -> i -> Either (ErrorSet e) a run rule = runIdentity . runM rule -- | Run a 'RuleT' against an input, returning a contextual parse result. runM :: (Monad context, IsError e) => RuleT i e context a -> i -> context (Either (ErrorSet e) a) runM rule = (\(Run x) -> x) . runRun rule ------------------------------------------------------------------------------- newtype Run error context output = Run (context (Either (ErrorSet error) output)) deriving (Functor, Applicative, Monad, MonadError (ErrorSet error)) via (ExceptT (ErrorSet error) context) instance MonadIO context => MonadIO (Run error context) where liftIO = lift . liftIO instance MonadTrans (Run error) where lift = Run . fmap Right runRun :: (Monad context, IsError e) => RuleT i e context a -> i -> Run e context a runRun rule = interpretWith rule interpret interpret :: (Monad context, IsError error) => Interpret error context (Run error context) interpret input = \case Fail e -> throwError1 e Lift lifted -> lift (lifted input) >>= either throwError1 pure TestMatch matches -> attachLocation input $ evalPatterns matches interpret input Traverse f g rule -> do fmap g . traverse (runRun rule) $ f input GetContent rule -> runRun rule $ input ^. P.content GetProperty k key -> input ^. P.hasProperty key & pure . k GetSetting k key parse -> input ^. P.atSetting key & traverse parse & either (throwError1 . ParseError key) (pure . k) GetRequiredSetting key parse -> do raw <- input ^. P.atSetting key & maybe (throwError1 $ Required key) pure either (throwError1 . ParseError key) pure $ parse raw GetSelf k -> pure $ k input