{-|
Module      : Prosidy.Compile.Run
Description : Interpretation of compilation rules.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Prosidy.Compile.Run (run, runM) where

import           Lens.Micro
import           Prosidy.Compile.Core
import           Prosidy.Compile.Error

import           Data.Bifunctor                 ( Bifunctor(..) )
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.
(Applicative 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
    :: (Applicative 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.
(Applicative 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

instance (Applicative context, IsError error) => Applicative (Run error context) where
    pure :: a -> Run error context a
pure = context (Either (ErrorSet error) a) -> Run error context a
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (context (Either (ErrorSet error) a) -> Run error context a)
-> (a -> context (Either (ErrorSet error) a))
-> a
-> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (ErrorSet error) a -> context (Either (ErrorSet error) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ErrorSet error) a -> context (Either (ErrorSet error) a))
-> (a -> Either (ErrorSet error) a)
-> a
-> context (Either (ErrorSet error) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either (ErrorSet error) a
forall a b. b -> Either a b
Right
    {-# INLINE pure #-}

    Run lhsF :: context (Either (ErrorSet error) (a -> b))
lhsF <*> :: Run error context (a -> b)
-> Run error context a -> Run error context b
<*> Run rhsF :: context (Either (ErrorSet error) a)
rhsF = context (Either (ErrorSet error) b) -> Run error context b
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (context (Either (ErrorSet error) b) -> Run error context b)
-> context (Either (ErrorSet error) b) -> Run error context b
forall a b. (a -> b) -> a -> b
$ do
        Either (ErrorSet error) (a -> b)
lhs <- context (Either (ErrorSet error) (a -> b))
lhsF
        Either (ErrorSet error) a
rhs <- context (Either (ErrorSet error) a)
rhsF
        pure $ (ErrorSet error -> Either (ErrorSet error) b)
-> ((a -> b) -> Either (ErrorSet error) b)
-> Either (ErrorSet error) (a -> b)
-> Either (ErrorSet error) b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\es :: ErrorSet error
es -> ErrorSet error -> Either (ErrorSet error) b
forall a b. a -> Either a b
Left (ErrorSet error -> Either (ErrorSet error) b)
-> ErrorSet error -> Either (ErrorSet error) b
forall a b. (a -> b) -> a -> b
$ (ErrorSet error -> ErrorSet error)
-> (a -> ErrorSet error)
-> Either (ErrorSet error) a
-> ErrorSet error
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorSet error
es ErrorSet error -> ErrorSet error -> ErrorSet error
forall a. Semigroup a => a -> a -> a
<>) (ErrorSet error -> a -> ErrorSet error
forall a b. a -> b -> a
const ErrorSet error
es) Either (ErrorSet error) a
rhs)
                      (\fn :: a -> b
fn -> (a -> b) -> Either (ErrorSet error) a -> Either (ErrorSet error) b
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a -> b
fn Either (ErrorSet error) a
rhs)
                      Either (ErrorSet error) (a -> b)
lhs

instance (Applicative context, IsError error) => ApError (ErrorSet error) (Run error context) where
    liftError :: ErrorSet error -> Run error context a
liftError = context (Either (ErrorSet error) a) -> Run error context a
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (context (Either (ErrorSet error) a) -> Run error context a)
-> (ErrorSet error -> context (Either (ErrorSet error) a))
-> ErrorSet error
-> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (ErrorSet error) a -> context (Either (ErrorSet error) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ErrorSet error) a -> context (Either (ErrorSet error) a))
-> (ErrorSet error -> Either (ErrorSet error) a)
-> ErrorSet error
-> context (Either (ErrorSet error) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorSet error -> Either (ErrorSet error) a
forall a b. a -> Either a b
Left
    {-# INLINE liftError #-}

    mapError :: (ErrorSet error -> ErrorSet error)
-> Run error context a -> Run error context a
mapError f :: ErrorSet error -> ErrorSet error
f (Run r :: context (Either (ErrorSet error) a)
r) = context (Either (ErrorSet error) a) -> Run error context a
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (context (Either (ErrorSet error) a) -> Run error context a)
-> context (Either (ErrorSet error) a) -> Run error context a
forall a b. (a -> b) -> a -> b
$ (Either (ErrorSet error) a -> Either (ErrorSet error) a)
-> context (Either (ErrorSet error) a)
-> context (Either (ErrorSet error) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorSet error -> ErrorSet error)
-> Either (ErrorSet error) a -> Either (ErrorSet error) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrorSet error -> ErrorSet error
f) context (Either (ErrorSet error) a)
r

runRun
    :: (Applicative 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.
(Applicative context, IsError error) =>
Interpret error context (Run error context)
interpret

interpret
    :: (Applicative 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.
(IsError e, ApErrors e m) =>
Error e -> m a
liftError1 Error error
e
    Lift lifted :: i -> context (Either (Error error) a)
lifted -> context (Either (ErrorSet error) a) -> Run error context a
forall error (context :: * -> *) output.
context (Either (ErrorSet error) output)
-> Run error context output
Run (context (Either (ErrorSet error) a) -> Run error context a)
-> (context (Either (Error error) a)
    -> context (Either (ErrorSet error) a))
-> context (Either (Error error) a)
-> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (Error error) a -> Either (ErrorSet error) a)
-> context (Either (Error error) a)
-> context (Either (ErrorSet error) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Error error -> ErrorSet error)
-> Either (Error error) a -> Either (ErrorSet error) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Error error -> ErrorSet error
forall e. Hashable e => Error e -> ErrorSet e
singleError) (context (Either (Error error) a) -> Run error context a)
-> context (Either (Error error) a) -> Run error context a
forall a b. (a -> b) -> a -> b
$ i -> context (Either (Error error) a)
lifted i
input
    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, ApErrors e m, HasLocation l) =>
l -> m a -> m a
groupErrors 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, ApErrors 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.
(Applicative 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.
(Applicative 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.
(Applicative 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.
(IsError e, ApErrors e m) =>
Error e -> m a
liftError1 (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
        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 a) -> Run error context a
forall a b. a -> (a -> b) -> b
& Run error context a
-> (Text -> Run error context a)
-> Maybe Text
-> Run error context a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (Error error -> Run error context a
forall e (m :: * -> *) a.
(IsError e, ApErrors e m) =>
Error e -> m a
liftError1 (Error error -> Run error context a)
-> Error error -> Run error context a
forall a b. (a -> b) -> a -> b
$ Key -> Error error
forall a. Key -> Error a
Required Key
key)
            ((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.
(IsError e, ApErrors e m) =>
Error e -> m a
liftError1 (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)
-> (Text -> Either String a) -> Text -> Run error context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String a
parse)
    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