{-|
Module      : Prosidy.Compile.Match
Description : Fallible pattern rules.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE DerivingVia #-}
module Prosidy.Compile.Match
    ( -- * DSL for matching cases
      Match
    , MatchM
    , match
    -- ** Specific matchers
    , break
    , breakWith
    , paragraph
    , text

    -- *** Tag matchers which strictly enforce metadata.
    , blockTag
    , inlineTag
    , literalTag

    -- *** Tag matchers which loosely enforce metadata.
    , blockTag'
    , inlineTag'
    , literalTag'
    )
where

import           Prelude                 hiding ( break )
import           Prosidy.Compile.Core
import           Prosidy.Compile.Error
import           Prosidy.Compile.Strict

import           Control.Monad.State            ( StateT(..)
                                                , State
                                                , modify'
                                                , execState
                                                )
import           Data.Monoid                    ( Endo(..) )
import           Data.Text                      ( Text )
import           Data.List.NonEmpty             ( NonEmpty(..) )

import qualified Prosidy                       as P

-- | The type of fallible pattern specifications.
type Match i e f a = MatchM i e a f ()

-- | A monadic interface for defining fallible patterns. In practice, @r@ will
-- always be instantiated to @()@— 'Match' can be more clear.
newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r)
  deriving (a -> MatchM i e a f b -> MatchM i e a f a
(a -> b) -> MatchM i e a f a -> MatchM i e a f b
(forall a b. (a -> b) -> MatchM i e a f a -> MatchM i e a f b)
-> (forall a b. a -> MatchM i e a f b -> MatchM i e a f a)
-> Functor (MatchM i e a f)
forall a b. a -> MatchM i e a f b -> MatchM i e a f a
forall a b. (a -> b) -> MatchM i e a f a -> MatchM i e a f b
forall i e a (f :: * -> *) a b.
a -> MatchM i e a f b -> MatchM i e a f a
forall i e a (f :: * -> *) a b.
(a -> b) -> MatchM i e a f a -> MatchM i e a f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> MatchM i e a f b -> MatchM i e a f a
$c<$ :: forall i e a (f :: * -> *) a b.
a -> MatchM i e a f b -> MatchM i e a f a
fmap :: (a -> b) -> MatchM i e a f a -> MatchM i e a f b
$cfmap :: forall i e a (f :: * -> *) a b.
(a -> b) -> MatchM i e a f a -> MatchM i e a f b
Functor, Functor (MatchM i e a f)
a -> MatchM i e a f a
Functor (MatchM i e a f) =>
(forall a. a -> MatchM i e a f a)
-> (forall a b.
    MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b)
-> (forall a b c.
    (a -> b -> c)
    -> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f c)
-> (forall a b.
    MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b)
-> (forall a b.
    MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a)
-> Applicative (MatchM i e a f)
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a
MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b
(a -> b -> c)
-> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f c
forall a. a -> MatchM i e a f a
forall a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a
forall a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
forall a b.
MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b
forall a b c.
(a -> b -> c)
-> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f c
forall i e a (f :: * -> *). Functor (MatchM i e a f)
forall i e a (f :: * -> *) a. a -> MatchM i e a f a
forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a
forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
forall i e a (f :: * -> *) a b.
MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b
forall i e a (f :: * -> *) a b c.
(a -> b -> c)
-> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f 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
<* :: MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a
$c<* :: forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f a
*> :: MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
$c*> :: forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
liftA2 :: (a -> b -> c)
-> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f c
$cliftA2 :: forall i e a (f :: * -> *) a b c.
(a -> b -> c)
-> MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f c
<*> :: MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b
$c<*> :: forall i e a (f :: * -> *) a b.
MatchM i e a f (a -> b) -> MatchM i e a f a -> MatchM i e a f b
pure :: a -> MatchM i e a f a
$cpure :: forall i e a (f :: * -> *) a. a -> MatchM i e a f a
$cp1Applicative :: forall i e a (f :: * -> *). Functor (MatchM i e a f)
Applicative, Applicative (MatchM i e a f)
a -> MatchM i e a f a
Applicative (MatchM i e a f) =>
(forall a b.
 MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f b)
-> (forall a b.
    MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b)
-> (forall a. a -> MatchM i e a f a)
-> Monad (MatchM i e a f)
MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f b
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
forall a. a -> MatchM i e a f a
forall a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
forall a b.
MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f b
forall i e a (f :: * -> *). Applicative (MatchM i e a f)
forall i e a (f :: * -> *) a. a -> MatchM i e a f a
forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
forall i e a (f :: * -> *) a b.
MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f 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 -> MatchM i e a f a
$creturn :: forall i e a (f :: * -> *) a. a -> MatchM i e a f a
>> :: MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
$c>> :: forall i e a (f :: * -> *) a b.
MatchM i e a f a -> MatchM i e a f b -> MatchM i e a f b
>>= :: MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f b
$c>>= :: forall i e a (f :: * -> *) a b.
MatchM i e a f a -> (a -> MatchM i e a f b) -> MatchM i e a f b
$cp1Monad :: forall i e a (f :: * -> *). Applicative (MatchM i e a f)
Monad)
    via State (Endo [Pattern i e f a])

-- | Finalize a 'Match' into a rule. This is often used to offset a match
-- block:
--
-- @
-- blocktags :: Match Block Void Identity String
-- blocktags = match $ do
--    ...
-- @
match :: (Applicative f, CanMatch i) => Match i e f a -> RuleT i e f a
match :: Match i e f a -> RuleT i e f a
match (MatchM s :: State (Endo [Pattern i e f a]) ()
s) = case Endo [Pattern i e f a] -> [Pattern i e f a] -> [Pattern i e f a]
forall a. Endo a -> a -> a
appEndo (State (Endo [Pattern i e f a]) ()
-> Endo [Pattern i e f a] -> Endo [Pattern i e f a]
forall s a. State s a -> s -> s
execState State (Endo [Pattern i e f a]) ()
s Endo [Pattern i e f a]
forall a. Monoid a => a
mempty) [] of
    x :: Pattern i e f a
x : xs :: [Pattern i e f a]
xs -> RuleF i e f a -> RuleT i e f a
forall i e (f :: * -> *) o. RuleF i e f o -> RuleT i e f o
rule (RuleF i e f a -> RuleT i e f a)
-> (NonEmpty (Pattern i e f a) -> RuleF i e f a)
-> NonEmpty (Pattern i e f a)
-> RuleT i e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Pattern i e f a) -> RuleF i e f a
forall input error (context :: * -> *) output.
CanMatch input =>
NonEmpty (Pattern input error context output)
-> RuleF input error context output
TestMatch (NonEmpty (Pattern i e f a) -> RuleT i e f a)
-> NonEmpty (Pattern i e f a) -> RuleT i e f a
forall a b. (a -> b) -> a -> b
$ Pattern i e f a
x Pattern i e f a -> [Pattern i e f a] -> NonEmpty (Pattern i e f a)
forall a. a -> [a] -> NonEmpty a
:| [Pattern i e f a]
xs
    []     -> RuleF i e f a -> RuleT i e f a
forall i e (f :: * -> *) o. RuleF i e f o -> RuleT i e f o
rule (RuleF i e f a -> RuleT i e f a) -> RuleF i e f a -> RuleT i e f a
forall a b. (a -> b) -> a -> b
$ Error e -> RuleF i e f a
forall error input (context :: * -> *) output.
Error error -> RuleF input error context output
Fail Error e
forall a. Error a
EmptyMatch

-- | Match against a 'Prosidy.Typs.Break'.
break :: RuleT () e f a -> Match P.Inline e f a
break :: RuleT () e f a -> Match Inline e f a
break = Pattern Inline e f a -> Match Inline e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Inline e f a -> Match Inline e f a)
-> (RuleT () e f a -> Pattern Inline e f a)
-> RuleT () e f a
-> Match Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT () e f a -> Pattern Inline e f a
forall error (context :: * -> *) output.
RuleT () error context output
-> Pattern Inline error context output
BreakP

-- | Replace all 'Prosidy.Types.Break's with the provided value.
breakWith :: a -> Match P.Inline e f a
breakWith :: a -> Match Inline e f a
breakWith = Pattern Inline e f a -> Match Inline e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Inline e f a -> Match Inline e f a)
-> (a -> Pattern Inline e f a) -> a -> Match Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT () e f a -> Pattern Inline e f a
forall error (context :: * -> *) output.
RuleT () error context output
-> Pattern Inline error context output
BreakP (RuleT () e f a -> Pattern Inline e f a)
-> (a -> RuleT () e f a) -> a -> Pattern Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RuleT () e f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Match 'Prosidy.Types.Paragraph's in a block context.
paragraph :: RuleT (P.SeriesNE P.Inline) e f a -> Match P.Block e f a
paragraph :: RuleT (SeriesNE Inline) e f a -> Match Block e f a
paragraph = Pattern Block e f a -> Match Block e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Block e f a -> Match Block e f a)
-> (RuleT (SeriesNE Inline) e f a -> Pattern Block e f a)
-> RuleT (SeriesNE Inline) e f a
-> Match Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT (SeriesNE Inline) e f a -> Pattern Block e f a
forall error (context :: * -> *) output.
RuleT (SeriesNE Inline) error context output
-> Pattern Block error context output
ParagraphP

-- | Match plain 'Text' in an inline context.
text :: RuleT Text e f a -> Match P.Inline e f a
text :: RuleT Text e f a -> Match Inline e f a
text = Pattern Inline e f a -> Match Inline e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Inline e f a -> Match Inline e f a)
-> (RuleT Text e f a -> Pattern Inline e f a)
-> RuleT Text e f a
-> Match Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT Text e f a -> Pattern Inline e f a
forall error (context :: * -> *) output.
RuleT Text error context output
-> Pattern Inline error context output
TextP

put :: Pattern i e f a -> Match i e f a
put :: Pattern i e f a -> Match i e f a
put x :: Pattern i e f a
x = State (Endo [Pattern i e f a]) () -> Match i e f a
forall i e a (f :: * -> *) r.
State (Endo [Pattern i e f a]) r -> MatchM i e a f r
MatchM (State (Endo [Pattern i e f a]) () -> Match i e f a)
-> State (Endo [Pattern i e f a]) () -> Match i e f a
forall a b. (a -> b) -> a -> b
$ (Endo [Pattern i e f a] -> Endo [Pattern i e f a])
-> State (Endo [Pattern i e f a]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (Endo [Pattern i e f a]
-> Endo [Pattern i e f a] -> Endo [Pattern i e f a]
forall a. Semigroup a => a -> a -> a
<> ([Pattern i e f a] -> [Pattern i e f a]) -> Endo [Pattern i e f a]
forall a. (a -> a) -> Endo a
Endo (Pattern i e f a
x Pattern i e f a -> [Pattern i e f a] -> [Pattern i e f a]
forall a. a -> [a] -> [a]
:))


-------------------------------------------------------------------------------
-- | Strict: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.
blockTag
    :: Applicative f => P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a
blockTag :: Key -> RuleT BlockRegion e f a -> Match Block e f a
blockTag key :: Key
key = Pattern Block e f a -> Match Block e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Block e f a -> Match Block e f a)
-> (RuleT BlockRegion e f a -> Pattern Block e f a)
-> RuleT BlockRegion e f a
-> Match Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT BlockRegion e f a -> Pattern Block e f a
forall error (context :: * -> *) output.
Key
-> RuleT BlockRegion error context output
-> Pattern Block error context output
BlockTagP Key
key (RuleT BlockRegion e f a -> Pattern Block e f a)
-> (RuleT BlockRegion e f a -> RuleT BlockRegion e f a)
-> RuleT BlockRegion e f a
-> Pattern Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT BlockRegion e f a -> RuleT BlockRegion e f a
forall (f :: * -> *) i e a.
(Applicative f, HasMetadata i) =>
RuleT i e f a -> RuleT i e f a
strict

-- | Strict: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.
inlineTag
    :: Applicative f
    => P.Key
    -> RuleT InlineRegion e f a
    -> Match P.Inline e f a
inlineTag :: Key -> RuleT InlineRegion e f a -> Match Inline e f a
inlineTag key :: Key
key = Pattern Inline e f a -> Match Inline e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Inline e f a -> Match Inline e f a)
-> (RuleT InlineRegion e f a -> Pattern Inline e f a)
-> RuleT InlineRegion e f a
-> Match Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT InlineRegion e f a -> Pattern Inline e f a
forall error (context :: * -> *) output.
Key
-> RuleT InlineRegion error context output
-> Pattern Inline error context output
InlineTagP Key
key (RuleT InlineRegion e f a -> Pattern Inline e f a)
-> (RuleT InlineRegion e f a -> RuleT InlineRegion e f a)
-> RuleT InlineRegion e f a
-> Pattern Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT InlineRegion e f a -> RuleT InlineRegion e f a
forall (f :: * -> *) i e a.
(Applicative f, HasMetadata i) =>
RuleT i e f a -> RuleT i e f a
strict

-- | Strict: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.
literalTag
    :: Applicative f
    => P.Key
    -> RuleT LiteralRegion e f a
    -> Match P.Block e f a
literalTag :: Key -> RuleT LiteralRegion e f a -> Match Block e f a
literalTag key :: Key
key = Pattern Block e f a -> Match Block e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Block e f a -> Match Block e f a)
-> (RuleT LiteralRegion e f a -> Pattern Block e f a)
-> RuleT LiteralRegion e f a
-> Match Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT LiteralRegion e f a -> Pattern Block e f a
forall error (context :: * -> *) output.
Key
-> RuleT LiteralRegion error context output
-> Pattern Block error context output
LitTagP Key
key (RuleT LiteralRegion e f a -> Pattern Block e f a)
-> (RuleT LiteralRegion e f a -> RuleT LiteralRegion e f a)
-> RuleT LiteralRegion e f a
-> Pattern Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT LiteralRegion e f a -> RuleT LiteralRegion e f a
forall (f :: * -> *) i e a.
(Applicative f, HasMetadata i) =>
RuleT i e f a -> RuleT i e f a
strict

-------------------------------------------------------------------------------
-- | Lax: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.
blockTag' :: P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a
blockTag' :: Key -> RuleT BlockRegion e f a -> Match Block e f a
blockTag' key :: Key
key = Pattern Block e f a -> Match Block e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Block e f a -> Match Block e f a)
-> (RuleT BlockRegion e f a -> Pattern Block e f a)
-> RuleT BlockRegion e f a
-> Match Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT BlockRegion e f a -> Pattern Block e f a
forall error (context :: * -> *) output.
Key
-> RuleT BlockRegion error context output
-> Pattern Block error context output
BlockTagP Key
key

-- | Lax: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.
inlineTag' :: P.Key -> RuleT InlineRegion e f a -> Match P.Inline e f a
inlineTag' :: Key -> RuleT InlineRegion e f a -> Match Inline e f a
inlineTag' key :: Key
key = Pattern Inline e f a -> Match Inline e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Inline e f a -> Match Inline e f a)
-> (RuleT InlineRegion e f a -> Pattern Inline e f a)
-> RuleT InlineRegion e f a
-> Match Inline e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT InlineRegion e f a -> Pattern Inline e f a
forall error (context :: * -> *) output.
Key
-> RuleT InlineRegion error context output
-> Pattern Inline error context output
InlineTagP Key
key

-- | Lax: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.
literalTag' :: P.Key -> RuleT LiteralRegion e f a -> Match P.Block e f a
literalTag' :: Key -> RuleT LiteralRegion e f a -> Match Block e f a
literalTag' key :: Key
key = Pattern Block e f a -> Match Block e f a
forall i e (f :: * -> *) a. Pattern i e f a -> Match i e f a
put (Pattern Block e f a -> Match Block e f a)
-> (RuleT LiteralRegion e f a -> Pattern Block e f a)
-> RuleT LiteralRegion e f a
-> Match Block e f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> RuleT LiteralRegion e f a -> Pattern Block e f a
forall error (context :: * -> *) output.
Key
-> RuleT LiteralRegion error context output
-> Pattern Block error context output
LitTagP Key
key