Run.hs

{-|
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