{-|
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 :: RuleT i e Identity a -> i -> Either (ErrorSet e) a
run rule :: RuleT i e Identity a
rule = Identity (Either (ErrorSet e) a) -> Either (ErrorSet e) a
forall a. Identity a -> a
runIdentity (Identity (Either (ErrorSet e) a) -> Either (ErrorSet e) a)
-> (i -> Identity (Either (ErrorSet e) a))
-> i
-> Either (ErrorSet e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT i e Identity a -> i -> Identity (Either (ErrorSet e) a)
forall (context :: * -> *) e i a.
(Monad context, IsError e) =>
RuleT i e context a -> i -> context (Either (ErrorSet e) a)
runM RuleT i e Identity a
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 :: RuleT i e context a -> i -> context (Either (ErrorSet e) a)
runM rule :: RuleT i e context a
rule = (\(Run x :: context (Either (ErrorSet e) a)
x) -> context (Either (ErrorSet e) a)
x) (Run e context a -> context (Either (ErrorSet e) a))
-> (i -> Run e context a) -> i -> context (Either (ErrorSet e) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT i e context a -> i -> Run e context a
forall (context :: * -> *) e i a.
(Monad context, IsError e) =>
RuleT i e context a -> i -> Run e context a
runRun RuleT i e context a
rule

-------------------------------------------------------------------------------
newtype Run error context output = Run
    (context (Either (ErrorSet error) output))
  deriving (a -> Run error context b -> Run error context a
(a -> b) -> Run error context a -> Run error context b
(forall a b.
 (a -> b) -> Run error context a -> Run error context b)
-> (forall a b. a -> Run error context b -> Run error context a)
-> Functor (Run error context)
forall a b. a -> Run error context b -> Run error context a
forall a b. (a -> b) -> Run error context a -> Run error context b
forall error (context :: * -> *) a b.
Functor context =>
a -> Run error context b -> Run error context a
forall error (context :: * -> *) a b.
Functor context =>
(a -> b) -> Run error context a -> Run error context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Run error context b -> Run error context a
$c<$ :: forall error (context :: * -> *) a b.
Functor context =>
a -> Run error context b -> Run error context a
fmap :: (a -> b) -> Run error context a -> Run error context b
$cfmap :: forall error (context :: * -> *) a b.
Functor context =>
(a -> b) -> Run error context a -> Run error context b
Functor, Functor (Run error context)
a -> Run error context a
Functor (Run error context) =>
(forall a. a -> Run error context a)
-> (forall a b.
    Run error context (a -> b)
    -> Run error context a -> Run error context b)
-> (forall a b c.
    (a -> b -> c)
    -> Run error context a
    -> Run error context b
    -> Run error context c)
-> (forall a b.
    Run error context a -> Run error context b -> Run error context b)
-> (forall a b.
    Run error context a -> Run error context b -> Run error context a)
-> Applicative (Run error context)
Run error context a -> Run error context b -> Run error context b
Run error context a -> Run error context b -> Run error context a
Run error context (a -> b)
-> Run error context a -> Run error context b
(a -> b -> c)
-> Run error context a
-> Run error context b
-> Run error context c
forall a. a -> Run error context a
forall a b.
Run error context a -> Run error context b -> Run error context a
forall a b.
Run error context a -> Run error context b -> Run error context b
forall a b.
Run error context (a -> b)
-> Run error context a -> Run error context b
forall a b c.
(a -> b -> c)
-> Run error context a
-> Run error context b
-> Run error context c
forall error (context :: * -> *).
Monad context =>
Functor (Run error context)
forall error (context :: * -> *) a.
Monad context =>
a -> Run error context a
forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context a
forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context b
forall error (context :: * -> *) a b.
Monad context =>
Run error context (a -> b)
-> Run error context a -> Run error context b
forall error (context :: * -> *) a b c.
Monad context =>
(a -> b -> c)
-> Run error context a
-> Run error context b
-> Run error context c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Run error context a -> Run error context b -> Run error context a
$c<* :: forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context a
*> :: Run error context a -> Run error context b -> Run error context b
$c*> :: forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context b
liftA2 :: (a -> b -> c)
-> Run error context a
-> Run error context b
-> Run error context c
$cliftA2 :: forall error (context :: * -> *) a b c.
Monad context =>
(a -> b -> c)
-> Run error context a
-> Run error context b
-> Run error context c
<*> :: Run error context (a -> b)
-> Run error context a -> Run error context b
$c<*> :: forall error (context :: * -> *) a b.
Monad context =>
Run error context (a -> b)
-> Run error context a -> Run error context b
pure :: a -> Run error context a
$cpure :: forall error (context :: * -> *) a.
Monad context =>
a -> Run error context a
$cp1Applicative :: forall error (context :: * -> *).
Monad context =>
Functor (Run error context)
Applicative, Applicative (Run error context)
a -> Run error context a
Applicative (Run error context) =>
(forall a b.
 Run error context a
 -> (a -> Run error context b) -> Run error context b)
-> (forall a b.
    Run error context a -> Run error context b -> Run error context b)
-> (forall a. a -> Run error context a)
-> Monad (Run error context)
Run error context a
-> (a -> Run error context b) -> Run error context b
Run error context a -> Run error context b -> Run error context b
forall a. a -> Run error context a
forall a b.
Run error context a -> Run error context b -> Run error context b
forall a b.
Run error context a
-> (a -> Run error context b) -> Run error context b
forall error (context :: * -> *).
Monad context =>
Applicative (Run error context)
forall error (context :: * -> *) a.
Monad context =>
a -> Run error context a
forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context b
forall error (context :: * -> *) a b.
Monad context =>
Run error context a
-> (a -> Run error context b) -> Run error context b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Run error context a
$creturn :: forall error (context :: * -> *) a.
Monad context =>
a -> Run error context a
>> :: Run error context a -> Run error context b -> Run error context b
$c>> :: forall error (context :: * -> *) a b.
Monad context =>
Run error context a -> Run error context b -> Run error context b
>>= :: Run error context a
-> (a -> Run error context b) -> Run error context b
$c>>= :: forall error (context :: * -> *) a b.
Monad context =>
Run error context a
-> (a -> Run error context b) -> Run error context b
$cp1Monad :: forall error (context :: * -> *).
Monad context =>
Applicative (Run error context)
Monad, MonadError (ErrorSet error))
    via (ExceptT (ErrorSet error) context)

instance MonadIO context => MonadIO (Run error context) where
    liftIO :: IO a -> Run error context a
liftIO = context a -> Run error context a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (context a -> Run error context a)
-> (IO a -> context a) -> IO a -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> context a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadTrans (Run error) where
    lift :: m a -> Run error m a
lift = m (Either (ErrorSet error) a) -> Run error m a
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (m (Either (ErrorSet error) a) -> Run error m a)
-> (m a -> m (Either (ErrorSet error) a)) -> m a -> Run error m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either (ErrorSet error) a)
-> m a -> m (Either (ErrorSet error) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either (ErrorSet error) a
forall a b. b -> Either a b
Right

runRun
    :: (Monad context, IsError e) => RuleT i e context a -> i -> Run e context a
runRun :: RuleT i e context a -> i -> Run e context a
runRun rule :: RuleT i e context a
rule = RuleT i e context a
-> Interpret e context (Run e context) -> i -> Run e context a
forall (g :: * -> *) i e (f :: * -> *) a.
Applicative g =>
RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith RuleT i e context a
rule Interpret e context (Run e context)
forall (context :: * -> *) error.
(Monad context, IsError error) =>
Interpret error context (Run error context)
interpret

interpret
    :: (Monad context, IsError error)
    => Interpret error context (Run error context)
interpret :: Interpret error context (Run error context)
interpret input :: i
input = \case
    Fail e :: Error error
e      -> Error error -> Run error context a
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 Error error
e
    Lift lifted :: i -> context (Either (Error error) a)
lifted -> context (Either (Error error) a)
-> Run error context (Either (Error error) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (i -> context (Either (Error error) a)
lifted i
input) Run error context (Either (Error error) a)
-> (Either (Error error) a -> Run error context a)
-> Run error context a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Error error -> Run error context a)
-> (a -> Run error context a)
-> Either (Error error) a
-> Run error context a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error error -> Run error context a
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 a -> Run error context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TestMatch matches :: NonEmpty (Pattern i error context a)
matches ->
        i -> Run error context a -> Run error context a
forall e (m :: * -> *) l a.
(IsError e, MonadErrors e m, HasLocation l) =>
l -> m a -> m a
attachLocation i
input (Run error context a -> Run error context a)
-> Run error context a -> Run error context a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Pattern i error context a)
-> Interpret error context (Run error context)
-> i
-> Run error context a
forall i e (g :: * -> *) (f :: * -> *) o.
(CanMatch i, IsError e, MonadErrors e g) =>
NonEmpty (Pattern i e f o) -> Interpret e f g -> i -> g o
evalPatterns NonEmpty (Pattern i error context a)
matches Interpret error context (Run error context)
forall (context :: * -> *) error.
(Monad context, IsError error) =>
Interpret error context (Run error context)
interpret i
input
    Traverse f :: i -> t i
f g :: t o -> a
g rule :: RuleT i error context o
rule -> do
        (t o -> a) -> Run error context (t o) -> Run error context a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t o -> a
g (Run error context (t o) -> Run error context a)
-> (t i -> Run error context (t o)) -> t i -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> Run error context o) -> t i -> Run error context (t o)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (RuleT i error context o -> i -> Run error context o
forall (context :: * -> *) e i a.
(Monad context, IsError e) =>
RuleT i e context a -> i -> Run e context a
runRun RuleT i error context o
rule) (t i -> Run error context a) -> t i -> Run error context a
forall a b. (a -> b) -> a -> b
$ i -> t i
f i
input
    GetContent rule :: RuleT (Content i) error context a
rule   -> RuleT (Content i) error context a
-> Content i -> Run error context a
forall (context :: * -> *) e i a.
(Monad context, IsError e) =>
RuleT i e context a -> i -> Run e context a
runRun RuleT (Content i) error context a
rule (Content i -> Run error context a)
-> Content i -> Run error context a
forall a b. (a -> b) -> a -> b
$ i
input i -> Getting (Content i) i (Content i) -> Content i
forall s a. s -> Getting a s a -> a
^. Getting (Content i) i (Content i)
forall t. HasContent t => Lens' t (Content t)
P.content
    GetProperty k :: Bool -> a
k key :: Key
key -> i
input i -> Getting Bool i Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Key -> Lens' i Bool
forall m. HasMetadata m => Key -> Lens' m Bool
P.hasProperty Key
key Bool -> (Bool -> Run error context a) -> Run error context a
forall a b. a -> (a -> b) -> b
& a -> Run error context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Run error context a)
-> (Bool -> a) -> Bool -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a
k
    GetSetting k :: Maybe x -> a
k key :: Key
key parse :: Text -> Either String x
parse ->
        i
input i -> Getting (Maybe Text) i (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Key -> Lens' i (Maybe Text)
forall m. HasMetadata m => Key -> Lens' m (Maybe Text)
P.atSetting Key
key Maybe Text
-> (Maybe Text -> Either String (Maybe x))
-> Either String (Maybe x)
forall a b. a -> (a -> b) -> b
& (Text -> Either String x) -> Maybe Text -> Either String (Maybe x)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either String x
parse Either String (Maybe x)
-> (Either String (Maybe x) -> Run error context a)
-> Run error context a
forall a b. a -> (a -> b) -> b
& (String -> Run error context a)
-> (Maybe x -> Run error context a)
-> Either String (Maybe x)
-> Run error context a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (Error error -> Run error context a
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 (Error error -> Run error context a)
-> (String -> Error error) -> String -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String -> Error error
forall a. Key -> String -> Error a
ParseError Key
key)
            (a -> Run error context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Run error context a)
-> (Maybe x -> a) -> Maybe x -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe x -> a
k)
    GetRequiredSetting key :: Key
key parse :: Text -> Either String a
parse -> do
        Text
raw <-
            i
input i -> Getting (Maybe Text) i (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Key -> Lens' i (Maybe Text)
forall m. HasMetadata m => Key -> Lens' m (Maybe Text)
P.atSetting Key
key Maybe Text
-> (Maybe Text -> Run error context Text) -> Run error context Text
forall a b. a -> (a -> b) -> b
& Run error context Text
-> (Text -> Run error context Text)
-> Maybe Text
-> Run error context Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error error -> Run error context Text
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 (Error error -> Run error context Text)
-> Error error -> Run error context Text
forall a b. (a -> b) -> a -> b
$ Key -> Error error
forall a. Key -> Error a
Required Key
key) Text -> Run error context Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (String -> Run error context a)
-> (a -> Run error context a)
-> Either String a
-> Run error context a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error error -> Run error context a
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 (Error error -> Run error context a)
-> (String -> Error error) -> String -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String -> Error error
forall a. Key -> String -> Error a
ParseError Key
key) a -> Run error context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> Run error context a)
-> Either String a -> Run error context a
forall a b. (a -> b) -> a -> b
$ Text -> Either String a
parse Text
raw
    GetSelf k :: i -> a
k -> a -> Run error context a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Run error context a) -> a -> Run error context a
forall a b. (a -> b) -> a -> b
$ i -> a
k i
input