{-|
Module      : Prosidy.Compile.Core
Description : Primitive type definitions and functions.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module Prosidy.Compile.Core
    ( RuleF(..)
    , RuleT
    , Rule
    , CanMatch(evalPattern, noMatchError)
    , Pattern(..)
    , Interpret
    , BlockRegion
    , InlineRegion
    , LiteralRegion
    , interpretWith
    , evalPatterns
    , rule
    )
where

import           Lens.Micro
import           Prosidy.Compile.Error

import           Prosidy                        ( Key
                                                , HasLocation
                                                , HasMetadata
                                                , HasContent(Content)
                                                )
import           Data.Text                      ( Text )
import           Data.Bifunctor                 ( Bifunctor(..) )
import           Data.List.NonEmpty             ( NonEmpty(..) )
import           Control.Monad.Except           ( runExceptT )
import           Control.Monad.Trans            ( MonadTrans(..) )
import           Data.Functor.Identity          ( Identity )

import qualified Prosidy
import qualified Control.Applicative.Free.Final
                                               as Ap

-- | A single compilation rule. Parameterized by the following types:
-- 
-- * @input@: The type of the Prosidy node that is currently accessible.
--
-- * @error@: Allows users to specify a custom error type to be used for 
-- throwing errors. 'Data.Void.Void' can be used to rely solely on
-- the errors built into this library.
--
-- * @context@: A 'Monad' for performing contextual computation beyond what
-- is provided by this library. If additional contextual computation is not
-- desired, use 'Data.Functor.Identity.Identity' as the type.
--
-- * @output@: The resulting output type.
newtype RuleT input error context output = RuleT
    (Ap.Ap (RuleF input error context) output)
  deriving (a -> RuleT input error context b -> RuleT input error context a
(a -> b)
-> RuleT input error context a -> RuleT input error context b
(forall a b.
 (a -> b)
 -> RuleT input error context a -> RuleT input error context b)
-> (forall a b.
    a -> RuleT input error context b -> RuleT input error context a)
-> Functor (RuleT input error context)
forall a b.
a -> RuleT input error context b -> RuleT input error context a
forall a b.
(a -> b)
-> RuleT input error context a -> RuleT input error context b
forall input error (context :: * -> *) a b.
a -> RuleT input error context b -> RuleT input error context a
forall input error (context :: * -> *) a b.
(a -> b)
-> RuleT input error context a -> RuleT input 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 -> RuleT input error context b -> RuleT input error context a
$c<$ :: forall input error (context :: * -> *) a b.
a -> RuleT input error context b -> RuleT input error context a
fmap :: (a -> b)
-> RuleT input error context a -> RuleT input error context b
$cfmap :: forall input error (context :: * -> *) a b.
(a -> b)
-> RuleT input error context a -> RuleT input error context b
Functor, Functor (RuleT input error context)
a -> RuleT input error context a
Functor (RuleT input error context) =>
(forall a. a -> RuleT input error context a)
-> (forall a b.
    RuleT input error context (a -> b)
    -> RuleT input error context a -> RuleT input error context b)
-> (forall a b c.
    (a -> b -> c)
    -> RuleT input error context a
    -> RuleT input error context b
    -> RuleT input error context c)
-> (forall a b.
    RuleT input error context a
    -> RuleT input error context b -> RuleT input error context b)
-> (forall a b.
    RuleT input error context a
    -> RuleT input error context b -> RuleT input error context a)
-> Applicative (RuleT input error context)
RuleT input error context a
-> RuleT input error context b -> RuleT input error context b
RuleT input error context a
-> RuleT input error context b -> RuleT input error context a
RuleT input error context (a -> b)
-> RuleT input error context a -> RuleT input error context b
(a -> b -> c)
-> RuleT input error context a
-> RuleT input error context b
-> RuleT input error context c
forall a. a -> RuleT input error context a
forall a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context a
forall a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context b
forall a b.
RuleT input error context (a -> b)
-> RuleT input error context a -> RuleT input error context b
forall a b c.
(a -> b -> c)
-> RuleT input error context a
-> RuleT input error context b
-> RuleT input error context c
forall input error (context :: * -> *).
Functor (RuleT input error context)
forall input error (context :: * -> *) a.
a -> RuleT input error context a
forall input error (context :: * -> *) a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context a
forall input error (context :: * -> *) a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context b
forall input error (context :: * -> *) a b.
RuleT input error context (a -> b)
-> RuleT input error context a -> RuleT input error context b
forall input error (context :: * -> *) a b c.
(a -> b -> c)
-> RuleT input error context a
-> RuleT input error context b
-> RuleT input 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
<* :: RuleT input error context a
-> RuleT input error context b -> RuleT input error context a
$c<* :: forall input error (context :: * -> *) a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context a
*> :: RuleT input error context a
-> RuleT input error context b -> RuleT input error context b
$c*> :: forall input error (context :: * -> *) a b.
RuleT input error context a
-> RuleT input error context b -> RuleT input error context b
liftA2 :: (a -> b -> c)
-> RuleT input error context a
-> RuleT input error context b
-> RuleT input error context c
$cliftA2 :: forall input error (context :: * -> *) a b c.
(a -> b -> c)
-> RuleT input error context a
-> RuleT input error context b
-> RuleT input error context c
<*> :: RuleT input error context (a -> b)
-> RuleT input error context a -> RuleT input error context b
$c<*> :: forall input error (context :: * -> *) a b.
RuleT input error context (a -> b)
-> RuleT input error context a -> RuleT input error context b
pure :: a -> RuleT input error context a
$cpure :: forall input error (context :: * -> *) a.
a -> RuleT input error context a
$cp1Applicative :: forall input error (context :: * -> *).
Functor (RuleT input error context)
Applicative)

instance MonadTrans (RuleT input error) where
    lift :: m a -> RuleT input error m a
lift = RuleF input error m a -> RuleT input error m a
forall i e (f :: * -> *) o. RuleF i e f o -> RuleT i e f o
rule (RuleF input error m a -> RuleT input error m a)
-> (m a -> RuleF input error m a) -> m a -> RuleT input error m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (input -> m (Either (Error error) a)) -> RuleF input error m a
forall input (context :: * -> *) error output.
(input -> context (Either (Error error) output))
-> RuleF input error context output
Lift ((input -> m (Either (Error error) a)) -> RuleF input error m a)
-> (m a -> input -> m (Either (Error error) a))
-> m a
-> RuleF input error m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either (Error error) a) -> input -> m (Either (Error error) a)
forall a b. a -> b -> a
const (m (Either (Error error) a) -> input -> m (Either (Error error) a))
-> (m a -> m (Either (Error error) a))
-> m a
-> input
-> m (Either (Error error) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either (Error error) a) -> m a -> m (Either (Error error) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either (Error error) a
forall a b. b -> Either a b
Right

-- | 'RuleT' without a contextual environment.
type Rule input error = RuleT input error Identity

-- | Lifts a 'RuleF' into a 'RuleT'.
rule :: RuleF i e f o -> RuleT i e f o
rule :: RuleF i e f o -> RuleT i e f o
rule = Ap (RuleF i e f) o -> RuleT i e f o
forall input error (context :: * -> *) output.
Ap (RuleF input error context) output
-> RuleT input error context output
RuleT (Ap (RuleF i e f) o -> RuleT i e f o)
-> (RuleF i e f o -> Ap (RuleF i e f) o)
-> RuleF i e f o
-> RuleT i e f o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleF i e f o -> Ap (RuleF i e f) o
forall (f :: * -> *) a. f a -> Ap f a
Ap.liftAp

-- | The control functor for compiling Prosidy elements. Each action 
-- corresponds to an action to perform on the @input@ variable.
--
-- See 'RuleT' and 'Rule' for use of this type.
data RuleF input error context output where
    -- | Throw an error.
    Fail
        ::Error error
        -> RuleF input error context output

    -- | Embed a raw action as a rule. Note: Please avoid using this if
    -- possible: it breaks static introspection!
    Lift
        ::(input -> context (Either (Error error) output))
        -> RuleF input error context output

    -- | Given a non-empty list of potential cases, construct a Rule that
    -- processes any items matching at least one of those cases.
    TestMatch
        ::(CanMatch input)
        => NonEmpty (Pattern input error context output)
        -> RuleF input error context output

    Traverse
        ::Traversable t
        => (input -> t i)
        -> (t o -> output)
        -> RuleT i error context o
        -> RuleF input error context output

    -- | When @input@ is a value wrapping some 'Content', enable access to that
    -- 'Content' by wrapping a 'RuleT'.
    GetContent
        ::HasContent input
        => RuleT (Content input) error context output
        -> RuleF input           error context output

    -- | Fetch a property from items with metadata.
    GetProperty
        ::HasMetadata input
        => (Bool -> a)
        -> Key
        -> RuleF input error context a

    -- | Fetch an /optional/ setting from items with metadata.
    GetSetting
        ::HasMetadata input
        => (Maybe x -> output)
        -> Key
        -> (Text -> Either String x)
        -> RuleF input error context output

    -- | Fetch a /required/ setting from items with metadata.
    GetRequiredSetting
        ::HasMetadata input
        => Key
        -> (Text -> Either String output)
        -> RuleF input error context output

    -- | Get the raw text from a 'Text' node.
    GetSelf
        ::(input -> output)
        -> RuleF input error context output

instance Functor context => Functor (RuleF input error context) where
    fmap :: (a -> b)
-> RuleF input error context a -> RuleF input error context b
fmap fn :: a -> b
fn = \case
        Fail      error :: Error error
error        -> Error error -> RuleF input error context b
forall error input (context :: * -> *) output.
Error error -> RuleF input error context output
Fail Error error
error
        Lift      lift :: input -> context (Either (Error error) a)
lift         -> (input -> context (Either (Error error) b))
-> RuleF input error context b
forall input (context :: * -> *) error output.
(input -> context (Either (Error error) output))
-> RuleF input error context output
Lift ((input -> context (Either (Error error) b))
 -> RuleF input error context b)
-> (input -> context (Either (Error error) b))
-> RuleF input error context b
forall a b. (a -> b) -> a -> b
$ (Either (Error error) a -> Either (Error error) b)
-> context (Either (Error error) a)
-> context (Either (Error error) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either (Error error) a -> Either (Error error) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn) (context (Either (Error error) a)
 -> context (Either (Error error) b))
-> (input -> context (Either (Error error) a))
-> input
-> context (Either (Error error) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> context (Either (Error error) a)
lift
        TestMatch matches :: NonEmpty (Pattern input error context a)
matches      -> NonEmpty (Pattern input error context b)
-> RuleF input error context b
forall input error (context :: * -> *) output.
CanMatch input =>
NonEmpty (Pattern input error context output)
-> RuleF input error context output
TestMatch (NonEmpty (Pattern input error context b)
 -> RuleF input error context b)
-> NonEmpty (Pattern input error context b)
-> RuleF input error context b
forall a b. (a -> b) -> a -> b
$ (Pattern input error context a -> Pattern input error context b)
-> NonEmpty (Pattern input error context a)
-> NonEmpty (Pattern input error context b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b)
-> Pattern input error context a -> Pattern input error context b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn) NonEmpty (Pattern input error context a)
matches
        Traverse f :: input -> t i
f g :: t o -> a
g rule :: RuleT i error context o
rule      -> (input -> t i)
-> (t o -> b)
-> RuleT i error context o
-> RuleF input error context b
forall (t :: * -> *) input i o output error (context :: * -> *).
Traversable t =>
(input -> t i)
-> (t o -> output)
-> RuleT i error context o
-> RuleF input error context output
Traverse input -> t i
f (a -> b
fn (a -> b) -> (t o -> a) -> t o -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t o -> a
g) RuleT i error context o
rule

        GetContent rule :: RuleT (Content input) error context a
rule        -> RuleT (Content input) error context b
-> RuleF input error context b
forall input error (context :: * -> *) output.
HasContent input =>
RuleT (Content input) error context output
-> RuleF input error context output
GetContent (RuleT (Content input) error context b
 -> RuleF input error context b)
-> RuleT (Content input) error context b
-> RuleF input error context b
forall a b. (a -> b) -> a -> b
$ (a -> b)
-> RuleT (Content input) error context a
-> RuleT (Content input) error context b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn RuleT (Content input) error context a
rule
        GetProperty k :: Bool -> a
k key :: Key
key      -> (Bool -> b) -> Key -> RuleF input error context b
forall input a error (context :: * -> *).
HasMetadata input =>
(Bool -> a) -> Key -> RuleF input error context a
GetProperty (a -> b
fn (a -> b) -> (Bool -> a) -> Bool -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a
k) Key
key
        GetSetting k :: Maybe x -> a
k key :: Key
key parse :: Text -> Either String x
parse -> (Maybe x -> b)
-> Key -> (Text -> Either String x) -> RuleF input error context b
forall input x output error (context :: * -> *).
HasMetadata input =>
(Maybe x -> output)
-> Key
-> (Text -> Either String x)
-> RuleF input error context output
GetSetting (a -> b
fn (a -> b) -> (Maybe x -> a) -> Maybe x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe x -> a
k) Key
key Text -> Either String x
parse
        GetRequiredSetting key :: Key
key parse :: Text -> Either String a
parse ->
            Key -> (Text -> Either String b) -> RuleF input error context b
forall input output error (context :: * -> *).
HasMetadata input =>
Key
-> (Text -> Either String output)
-> RuleF input error context output
GetRequiredSetting Key
key ((a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
fn (Either String a -> Either String b)
-> (Text -> Either String a) -> Text -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String a
parse)
        GetSelf k :: input -> a
k -> (input -> b) -> RuleF input error context b
forall input output error (context :: * -> *).
(input -> output) -> RuleF input error context output
GetSelf (a -> b
fn (a -> b) -> (input -> a) -> input -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> a
k)

-------------------------------------------------------------------------------
-- | A (lawless) typeclass for enabling fallible matching on nodes.
--
-- Implementing new instances of this class in library code is *unneccessary*
-- and *unsupported*.
class (forall i e. Functor (Pattern t i e), HasLocation t) => CanMatch t where
    -- | A data type representing allowable fallible patterns for @t@.
    data family Pattern t :: * -> (* -> *) -> * -> *

    -- | Information about why a @Pattern@ failed to match.
    data family NoMatch t :: *

    -- | Attempt to match a pattern against a value.
    evalPattern ::
           Applicative g
        => Pattern t error context output
           -- ^ The @Pattern@ to match against
        -> Interpret error context g
           -- ^ An interpreter for evaluating the match.
        -> t
           -- ^ The value to attempt to match against
        -> Either (NoMatch t) (g output)

    -- | Lift a @NoMatch@ error into the 'Error' type.
    noMatchError :: NoMatch t -> Error e

instance CanMatch Prosidy.Block where
    data Pattern Prosidy.Block error context output =
        BlockTagP  Key (RuleT BlockRegion                       error context output)
      | LitTagP    Key (RuleT LiteralRegion                     error context output)
      | ParagraphP     (RuleT (Prosidy.SeriesNE Prosidy.Inline) error context output)
      deriving a -> Pattern Block error context b -> Pattern Block error context a
(a -> b)
-> Pattern Block error context a -> Pattern Block error context b
(forall a b.
 (a -> b)
 -> Pattern Block error context a -> Pattern Block error context b)
-> (forall a b.
    a
    -> Pattern Block error context b -> Pattern Block error context a)
-> Functor (Pattern Block error context)
forall a b.
a -> Pattern Block error context b -> Pattern Block error context a
forall a b.
(a -> b)
-> Pattern Block error context a -> Pattern Block error context b
forall error (context :: * -> *) a b.
a -> Pattern Block error context b -> Pattern Block error context a
forall error (context :: * -> *) a b.
(a -> b)
-> Pattern Block error context a -> Pattern Block 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 -> Pattern Block error context b -> Pattern Block error context a
$c<$ :: forall error (context :: * -> *) a b.
a -> Pattern Block error context b -> Pattern Block error context a
fmap :: (a -> b)
-> Pattern Block error context a -> Pattern Block error context b
$cfmap :: forall error (context :: * -> *) a b.
(a -> b)
-> Pattern Block error context a -> Pattern Block error context b
Functor
    
    data NoMatch Prosidy.Block =
        NoMatchBlockTag  Key
      | NoMatchLitTag    Key
      | NoMatchParagraph

    evalPattern :: Pattern Block error context output
-> Interpret error context g
-> Block
-> Either (NoMatch Block) (g output)
evalPattern (BlockTagP key rule) = Traversal' Block BlockRegion
-> NoMatch Block
-> RuleT BlockRegion error context output
-> Interpret error context g
-> Block
-> Either (NoMatch Block) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith
        (Optic (->) f Block Block BlockTag BlockTag
Prism' Block BlockTag
Prosidy._BlockTag Optic (->) f Block Block BlockTag BlockTag
-> ((BlockRegion -> f BlockRegion) -> BlockTag -> f BlockTag)
-> (BlockRegion -> f BlockRegion)
-> Block
-> f Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Prism' BlockTag BlockRegion
forall a. Key -> Prism' (Tag a) (Region a)
Prosidy.tagged Key
key)
        (Key -> NoMatch Block
NoMatchBlockTag Key
key)
        RuleT BlockRegion error context output
rule
    evalPattern (LitTagP key rule) = Traversal' Block LiteralRegion
-> NoMatch Block
-> RuleT LiteralRegion error context output
-> Interpret error context g
-> Block
-> Either (NoMatch Block) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith
        (Optic (->) f Block Block LiteralTag LiteralTag
Prism' Block LiteralTag
Prosidy._BlockLiteral Optic (->) f Block Block LiteralTag LiteralTag
-> ((LiteralRegion -> f LiteralRegion)
    -> LiteralTag -> f LiteralTag)
-> (LiteralRegion -> f LiteralRegion)
-> Block
-> f Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Prism' LiteralTag LiteralRegion
forall a. Key -> Prism' (Tag a) (Region a)
Prosidy.tagged Key
key)
        (Key -> NoMatch Block
NoMatchLitTag Key
key)
        RuleT LiteralRegion error context output
rule
    evalPattern (ParagraphP rule) = Traversal' Block (SeriesNE Inline)
-> NoMatch Block
-> RuleT (SeriesNE Inline) error context output
-> Interpret error context g
-> Block
-> Either (NoMatch Block) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith
        (Optic (->) f Block Block Paragraph Paragraph
Prism' Block Paragraph
Prosidy._BlockParagraph Optic (->) f Block Block Paragraph Paragraph
-> ((SeriesNE Inline -> f (SeriesNE Inline))
    -> Paragraph -> f Paragraph)
-> (SeriesNE Inline -> f (SeriesNE Inline))
-> Block
-> f Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SeriesNE Inline -> f (SeriesNE Inline))
-> Paragraph -> f Paragraph
forall t. HasContent t => Lens' t (Content t)
Prosidy.content)
        NoMatch Block
NoMatchParagraph
        RuleT (SeriesNE Inline) error context output
rule

    noMatchError :: NoMatch Block -> Error e
noMatchError (NoMatchBlockTag key) = TagKind -> Key -> Error e
forall a. TagKind -> Key -> Error a
ExpectedTag TagKind
BlockKind Key
key
    noMatchError (NoMatchLitTag   key) = TagKind -> Key -> Error e
forall a. TagKind -> Key -> Error a
ExpectedTag TagKind
LiteralKind Key
key
    noMatchError NoMatchParagraph      = Error e
forall a. Error a
ExpectedParagraph

instance CanMatch Prosidy.Inline where
    data Pattern Prosidy.Inline error context output =
        InlineTagP Key (RuleT InlineRegion error context output)
      | BreakP         (RuleT ()           error context output)
      | TextP          (RuleT Text         error context output)
      deriving a
-> Pattern Inline error context b -> Pattern Inline error context a
(a -> b)
-> Pattern Inline error context a -> Pattern Inline error context b
(forall a b.
 (a -> b)
 -> Pattern Inline error context a
 -> Pattern Inline error context b)
-> (forall a b.
    a
    -> Pattern Inline error context b
    -> Pattern Inline error context a)
-> Functor (Pattern Inline error context)
forall a b.
a
-> Pattern Inline error context b -> Pattern Inline error context a
forall a b.
(a -> b)
-> Pattern Inline error context a -> Pattern Inline error context b
forall error (context :: * -> *) a b.
a
-> Pattern Inline error context b -> Pattern Inline error context a
forall error (context :: * -> *) a b.
(a -> b)
-> Pattern Inline error context a -> Pattern Inline 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
-> Pattern Inline error context b -> Pattern Inline error context a
$c<$ :: forall error (context :: * -> *) a b.
a
-> Pattern Inline error context b -> Pattern Inline error context a
fmap :: (a -> b)
-> Pattern Inline error context a -> Pattern Inline error context b
$cfmap :: forall error (context :: * -> *) a b.
(a -> b)
-> Pattern Inline error context a -> Pattern Inline error context b
Functor
    
    data NoMatch Prosidy.Inline =
        NoMatchInlineTag Key
      | NoMatchBreak
      | NoMatchText

    evalPattern :: Pattern Inline error context output
-> Interpret error context g
-> Inline
-> Either (NoMatch Inline) (g output)
evalPattern (InlineTagP key rule) = Traversal' Inline InlineRegion
-> NoMatch Inline
-> RuleT InlineRegion error context output
-> Interpret error context g
-> Inline
-> Either (NoMatch Inline) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith
        (Optic (->) f Inline Inline InlineTag InlineTag
Prism' Inline InlineTag
Prosidy._InlineTag Optic (->) f Inline Inline InlineTag InlineTag
-> ((InlineRegion -> f InlineRegion) -> InlineTag -> f InlineTag)
-> (InlineRegion -> f InlineRegion)
-> Inline
-> f Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Prism' InlineTag InlineRegion
forall a. Key -> Prism' (Tag a) (Region a)
Prosidy.tagged Key
key)
        (Key -> NoMatch Inline
NoMatchInlineTag Key
key)
        RuleT InlineRegion error context output
rule
    evalPattern (TextP rule) =
        Traversal' Inline Text
-> NoMatch Inline
-> RuleT Text error context output
-> Interpret error context g
-> Inline
-> Either (NoMatch Inline) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith (Optic (->) f Inline Inline Fragment Fragment
Prism' Inline Fragment
Prosidy._Text Optic (->) f Inline Inline Fragment Fragment
-> ((Text -> f Text) -> Fragment -> f Fragment)
-> (Text -> f Text)
-> Inline
-> f Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> Fragment -> f Fragment
Lens' Fragment Text
Prosidy.fragment) NoMatch Inline
NoMatchText RuleT Text error context output
rule
    evalPattern (BreakP rule) =
        Traversal' Inline ()
-> NoMatch Inline
-> RuleT () error context output
-> Interpret error context g
-> Inline
-> Either (NoMatch Inline) (g output)
forall (g :: * -> *) i j e e' (f :: * -> *) o.
Applicative g =>
Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith Traversal' Inline ()
Prism' Inline ()
Prosidy._Break NoMatch Inline
NoMatchBreak RuleT () error context output
rule

    noMatchError :: NoMatch Inline -> Error e
noMatchError (NoMatchInlineTag key) = TagKind -> Key -> Error e
forall a. TagKind -> Key -> Error a
ExpectedTag TagKind
InlineKind Key
key
    noMatchError NoMatchText            = Error e
forall a. Error a
ExpectedText
    noMatchError NoMatchBreak           = Error e
forall a. Error a
ExpectedBreak

-- | Match one or more patterns, in sequence, against a value. The result from
-- the first successful pattern will be returned. Subsequent matches will not
-- be tried.
evalPatterns
    :: (CanMatch i, IsError e, MonadErrors e g)
    => NonEmpty (Pattern i e f o)
    -> Interpret e f g
    -> i
    -> g o
evalPatterns :: NonEmpty (Pattern i e f o) -> Interpret e f g -> i -> g o
evalPatterns (x :: Pattern i e f o
x :| xs :: [Pattern i e f o]
xs) interpret :: Interpret e f g
interpret input :: i
input =
    ExceptT (ErrorSet e) g o -> g (Either (ErrorSet e) o)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (ErrorSet e) g o
folded g (Either (ErrorSet e) o) -> (Either (ErrorSet e) o -> g o) -> g o
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ErrorSet e -> g o) -> (o -> g o) -> Either (ErrorSet e) o -> g o
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorSet e -> g o
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError o -> g o
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    folded :: ExceptT (ErrorSet e) g o
folded = (Pattern i e f o
 -> ExceptT (ErrorSet e) g o -> ExceptT (ErrorSet e) g o)
-> ExceptT (ErrorSet e) g o
-> [Pattern i e f o]
-> ExceptT (ErrorSet e) g o
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\pat :: Pattern i e f o
pat acc :: ExceptT (ErrorSet e) g o
acc -> Pattern i e f o -> ExceptT (ErrorSet e) g o
doEval Pattern i e f o
pat ExceptT (ErrorSet e) g o
-> ExceptT (ErrorSet e) g o -> ExceptT (ErrorSet e) g o
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e b.
(MonadTrans t, Monad m, MonadError e (t m), Semigroup e) =>
ExceptT e m b -> t m b -> t m b
`orElse` ExceptT (ErrorSet e) g o
acc) (Pattern i e f o -> ExceptT (ErrorSet e) g o
doEval Pattern i e f o
x) [Pattern i e f o]
xs
    doEval :: Pattern i e f o -> ExceptT (ErrorSet e) g o
doEval pat :: Pattern i e f o
pat = (NoMatch i -> ExceptT (ErrorSet e) g o)
-> (g o -> ExceptT (ErrorSet e) g o)
-> Either (NoMatch i) (g o)
-> ExceptT (ErrorSet e) g o
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error e -> ExceptT (ErrorSet e) g o
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 (Error e -> ExceptT (ErrorSet e) g o)
-> (NoMatch i -> Error e) -> NoMatch i -> ExceptT (ErrorSet e) g o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoMatch i -> Error e
forall t e. CanMatch t => NoMatch t -> Error e
noMatchError) g o -> ExceptT (ErrorSet e) g o
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (Either (NoMatch i) (g o) -> ExceptT (ErrorSet e) g o)
-> Either (NoMatch i) (g o) -> ExceptT (ErrorSet e) g o
forall a b. (a -> b) -> a -> b
$ Pattern i e f o -> Interpret e f g -> i -> Either (NoMatch i) (g o)
forall t (g :: * -> *) error (context :: * -> *) output.
(CanMatch t, Applicative g) =>
Pattern t error context output
-> Interpret error context g -> t -> Either (NoMatch t) (g output)
evalPattern Pattern i e f o
pat Interpret e f g
interpret i
input
    orElse :: ExceptT e m b -> t m b -> t m b
orElse lhsM :: ExceptT e m b
lhsM rhsM :: t m b
rhsM = do
        Either e b
lhs <- m (Either e b) -> t m (Either e b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either e b) -> t m (Either e b))
-> m (Either e b) -> t m (Either e b)
forall a b. (a -> b) -> a -> b
$ ExceptT e m b -> m (Either e b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m b
lhsM
        case Either e b
lhs of
            Right ok :: b
ok  -> b -> t m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
ok
            Left  err :: e
err -> t m b
rhsM t m b -> (e -> t m b) -> t m b
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \err' :: e
err' -> e -> t m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> t m b) -> e -> t m b
forall a b. (a -> b) -> a -> b
$ e
err e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
err'

evalPatternWith
    :: Applicative g
    => Traversal' i j
    -> e
    -> RuleT j e' f o
    -> Interpret e' f g
    -> i
    -> Either e (g o)
evalPatternWith :: Traversal' i j
-> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o)
evalPatternWith sel :: Traversal' i j
sel error :: e
error rule :: RuleT j e' f o
rule interpret :: Interpret e' f g
interpret input :: i
input =
    (j -> g o) -> Either e j -> Either e (g o)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RuleT j e' f o -> Interpret e' f g -> j -> g o
forall (g :: * -> *) i e (f :: * -> *) a.
Applicative g =>
RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith RuleT j e' f o
rule Interpret e' f g
interpret)
        (Either e j -> Either e (g o))
-> (Maybe j -> Either e j) -> Maybe j -> Either e (g o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Either e j -> (j -> Either e j) -> Maybe j -> Either e j
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e j
forall a b. a -> Either a b
Left e
error) j -> Either e j
forall a b. b -> Either a b
Right
        (Maybe j -> Either e (g o)) -> Maybe j -> Either e (g o)
forall a b. (a -> b) -> a -> b
$  i
input
        i -> Getting (First j) i j -> Maybe j
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First j) i j
Traversal' i j
sel

-------------------------------------------------------------------------------
-- | Build an interpreter into a functor @g@.
interpretWith :: Applicative g => RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith :: RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith (RuleT ap :: Ap (RuleF i e f) a
ap) int :: Interpret e f g
int i :: i
i = (forall x. RuleF i e f x -> g x) -> Ap (RuleF i e f) a -> g a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
Ap.runAp (i -> RuleF i e f x -> g x
Interpret e f g
int i
i) Ap (RuleF i e f) a
ap

-------------------------------------------------------------------------------
-- | Runs a single 'RuleF' into an applicative @g@. Passing this value to
-- 'interpretWith' will fully evaluate a 'RuleT' into the same functor.
type Interpret e f g = forall i a . i -> RuleF i e f a -> g a

-------------------------------------------------------------------------------
-- | A 'Prosidy.Types.BlockTag' with the tag name removed.
type BlockRegion = Prosidy.Region (Prosidy.Series Prosidy.Block)

-- | An 'Prosidy.Types.InlineTag' with the tag name removed.
type InlineRegion = Prosidy.Region (Prosidy.Series Prosidy.Inline)

-- | A 'Prosidy.Types.LiteralTag' with the tag name removed.
type LiteralRegion = Prosidy.Region Text