{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Prosidy.Compile.Run (RunError(..), RunErrors(..), RunT, Run, run, runT) where
import Lens.Micro
import qualified Prosidy as P
import qualified Prosidy.Source as PS
import Prosidy.Types.Series ( pattern Empty
, pattern (:<:)
, pattern (:<<:)
)
import Control.Exception (Exception(..))
import Prosidy.Compile.Core
import Data.Function ( on )
import Data.Functor.Identity ( Identity(..) )
import Data.Bifunctor ( Bifunctor(..) )
import Data.Profunctor ( Profunctor(..)
, Strong(..)
)
import Data.Either.Valid (Valid(..))
import qualified Data.Either.Valid as Valid
import Data.Text ( Text )
import Control.Monad (unless)
import Data.Set (Set)
import Data.Foldable (toList, foldl')
import qualified Data.HashMap.Strict as HM
import Data.Semigroup (Semigroup(..))
import Data.Text.Prettyprint.Doc (Pretty(..), (<+>))
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.String as PPS
import qualified Data.HashSet as HashSet
import qualified Data.Set as Set
import qualified Data.Text as Text
type Run = RunT Identity
newtype RunT f t a = RunT
{ RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run :: t -> Observe -> Valid RunErrors (f a, Observe) }
instance Functor f => Functor (RunT f t) where
fmap :: (a -> b) -> RunT f t a -> RunT f t b
fmap = (a -> b) -> RunT f t a -> RunT f t b
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
instance Applicative f => Applicative (RunT f t) where
pure :: a -> RunT f t a
pure x :: a
x = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall a b. (a -> b) -> a -> b
$ \_ o :: Observe
o -> (f a, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x, Observe
o)
RunT lhs :: t -> Observe -> Valid RunErrors (f (a -> b), Observe)
lhs <*> :: RunT f t (a -> b) -> RunT f t a -> RunT f t b
<*> RunT rhs :: t -> Observe -> Valid RunErrors (f a, Observe)
rhs = (t -> Observe -> Valid RunErrors (f b, Observe)) -> RunT f t b
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f b, Observe)) -> RunT f t b)
-> (t -> Observe -> Valid RunErrors (f b, Observe)) -> RunT f t b
forall a b. (a -> b) -> a -> b
$ \t :: t
t obs :: Observe
obs ->
let
combine :: (f (a -> b), b) -> (f a, b) -> (f b, b)
combine ~(f :: f (a -> b)
f, o1 :: b
o1) ~(x :: f a
x, o2 :: b
o2) = (f (a -> b)
f f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
x, b
o1 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
o2)
in
(f (a -> b), Observe) -> (f a, Observe) -> (f b, Observe)
forall (f :: * -> *) b a b.
(Applicative f, Semigroup b) =>
(f (a -> b), b) -> (f a, b) -> (f b, b)
combine ((f (a -> b), Observe) -> (f a, Observe) -> (f b, Observe))
-> Valid RunErrors (f (a -> b), Observe)
-> Valid RunErrors ((f a, Observe) -> (f b, Observe))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Observe -> Valid RunErrors (f (a -> b), Observe)
lhs t
t Observe
obs Valid RunErrors ((f a, Observe) -> (f b, Observe))
-> Valid RunErrors (f a, Observe) -> Valid RunErrors (f b, Observe)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> Observe -> Valid RunErrors (f a, Observe)
rhs t
t Observe
obs
instance Applicative f => Alternative (RunT f t) where
empty :: RunT f t a
empty = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall a b. (a -> b) -> a -> b
$ \_ _ -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a. Alternative f => f a
empty
RunT lhs :: t -> Observe -> Valid RunErrors (f a, Observe)
lhs <|> :: RunT f t a -> RunT f t a -> RunT f t a
<|> RunT rhs :: t -> Observe -> Valid RunErrors (f a, Observe)
rhs = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall a b. (a -> b) -> a -> b
$ \t :: t
t obs :: Observe
obs ->
t -> Observe -> Valid RunErrors (f a, Observe)
lhs t
t Observe
obs Valid RunErrors (f a, Observe)
-> Valid RunErrors (f a, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> t -> Observe -> Valid RunErrors (f a, Observe)
rhs t
t Observe
obs
instance Functor f => Profunctor (RunT f) where
dimap :: (a -> b) -> (c -> d) -> RunT f b c -> RunT f a d
dimap f :: a -> b
f g :: c -> d
g = (a -> Observe -> Valid RunErrors (f d, Observe)) -> RunT f a d
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((a -> Observe -> Valid RunErrors (f d, Observe)) -> RunT f a d)
-> (RunT f b c -> a -> Observe -> Valid RunErrors (f d, Observe))
-> RunT f b c
-> RunT f a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Observe -> Valid RunErrors (f c, Observe))
-> a -> Observe -> Valid RunErrors (f d, Observe)
go ((b -> Observe -> Valid RunErrors (f c, Observe))
-> a -> Observe -> Valid RunErrors (f d, Observe))
-> (RunT f b c -> b -> Observe -> Valid RunErrors (f c, Observe))
-> RunT f b c
-> a
-> Observe
-> Valid RunErrors (f d, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunT f b c -> b -> Observe -> Valid RunErrors (f c, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run
where
go :: (b -> Observe -> Valid RunErrors (f c, Observe))
-> a -> Observe -> Valid RunErrors (f d, Observe)
go r :: b -> Observe -> Valid RunErrors (f c, Observe)
r t :: a
t obs :: Observe
obs = (f c -> f d) -> (f c, Observe) -> (f d, Observe)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) ((f c, Observe) -> (f d, Observe))
-> Valid RunErrors (f c, Observe) -> Valid RunErrors (f d, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Observe -> Valid RunErrors (f c, Observe)
r (a -> b
f a
t) Observe
obs
instance Functor f => Strong (RunT f) where
first' :: RunT f a b -> RunT f (a, c) (b, c)
first' = ((a, c) -> Observe -> Valid RunErrors (f (b, c), Observe))
-> RunT f (a, c) (b, c)
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT (((a, c) -> Observe -> Valid RunErrors (f (b, c), Observe))
-> RunT f (a, c) (b, c))
-> (RunT f a b
-> (a, c) -> Observe -> Valid RunErrors (f (b, c), Observe))
-> RunT f a b
-> RunT f (a, c) (b, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Observe -> Valid RunErrors (f b, Observe))
-> (a, c) -> Observe -> Valid RunErrors (f (b, c), Observe)
forall (p :: * -> * -> *) (f :: * -> *) (f :: * -> *) t t t c t.
(Bifunctor p, Functor f, Functor f) =>
(t -> t -> f (p (f t) c)) -> (t, t) -> t -> f (p (f (t, t)) c)
go ((a -> Observe -> Valid RunErrors (f b, Observe))
-> (a, c) -> Observe -> Valid RunErrors (f (b, c), Observe))
-> (RunT f a b -> a -> Observe -> Valid RunErrors (f b, Observe))
-> RunT f a b
-> (a, c)
-> Observe
-> Valid RunErrors (f (b, c), Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunT f a b -> a -> Observe -> Valid RunErrors (f b, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run
where
go :: (t -> t -> f (p (f t) c)) -> (t, t) -> t -> f (p (f (t, t)) c)
go r :: t -> t -> f (p (f t) c)
r (t :: t
t, c :: t
c) obs :: t
obs = (f t -> f (t, t)) -> p (f t) c -> p (f (t, t)) c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((t -> (t, t)) -> f t -> f (t, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, t
c)) (p (f t) c -> p (f (t, t)) c)
-> f (p (f t) c) -> f (p (f (t, t)) c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> f (p (f t) c)
r t
t t
obs
second' :: RunT f a b -> RunT f (c, a) (c, b)
second' = ((c, a) -> Observe -> Valid RunErrors (f (c, b), Observe))
-> RunT f (c, a) (c, b)
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT (((c, a) -> Observe -> Valid RunErrors (f (c, b), Observe))
-> RunT f (c, a) (c, b))
-> (RunT f a b
-> (c, a) -> Observe -> Valid RunErrors (f (c, b), Observe))
-> RunT f a b
-> RunT f (c, a) (c, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Observe -> Valid RunErrors (f b, Observe))
-> (c, a) -> Observe -> Valid RunErrors (f (c, b), Observe)
forall (p :: * -> * -> *) (f :: * -> *) (f :: * -> *) t t t c t.
(Bifunctor p, Functor f, Functor f) =>
(t -> t -> f (p (f t) c)) -> (t, t) -> t -> f (p (f (t, t)) c)
go ((a -> Observe -> Valid RunErrors (f b, Observe))
-> (c, a) -> Observe -> Valid RunErrors (f (c, b), Observe))
-> (RunT f a b -> a -> Observe -> Valid RunErrors (f b, Observe))
-> RunT f a b
-> (c, a)
-> Observe
-> Valid RunErrors (f (c, b), Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunT f a b -> a -> Observe -> Valid RunErrors (f b, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run
where
go :: (t -> t -> f (p (f t) c)) -> (t, t) -> t -> f (p (f (t, t)) c)
go r :: t -> t -> f (p (f t) c)
r (c :: t
c, t :: t
t) obs :: t
obs = (f t -> f (t, t)) -> p (f t) c -> p (f (t, t)) c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((t -> (t, t)) -> f t -> f (t, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t
c ,)) (p (f t) c -> p (f (t, t)) c)
-> f (p (f t) c) -> f (p (f (t, t)) c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> f (p (f t) c)
r t
t t
obs
run :: i -> Run i a -> Either RunErrors a
run :: i -> Run i a -> Either RunErrors a
run = ((Identity a -> a)
-> Either RunErrors (Identity a) -> Either RunErrors a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity a -> a
forall a. Identity a -> a
runIdentity (Either RunErrors (Identity a) -> Either RunErrors a)
-> (Run i a -> Either RunErrors (Identity a))
-> Run i a
-> Either RunErrors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Run i a -> Either RunErrors (Identity a))
-> Run i a -> Either RunErrors a)
-> (i -> Run i a -> Either RunErrors (Identity a))
-> i
-> Run i a
-> Either RunErrors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Run i a -> Either RunErrors (Identity a)
forall i (f :: * -> *) a. i -> RunT f i a -> Either RunErrors (f a)
runT
runT :: i -> RunT f i a -> Either RunErrors (f a)
runT :: i -> RunT f i a -> Either RunErrors (f a)
runT i :: i
i = ((f a, Observe) -> f a)
-> Either RunErrors (f a, Observe) -> Either RunErrors (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a, Observe) -> f a
forall a b. (a, b) -> a
fst (Either RunErrors (f a, Observe) -> Either RunErrors (f a))
-> (RunT f i a -> Either RunErrors (f a, Observe))
-> RunT f i a
-> Either RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Valid RunErrors (f a, Observe) -> Either RunErrors (f a, Observe)
forall e a. Valid e a -> Either e a
Valid.toEither (Valid RunErrors (f a, Observe) -> Either RunErrors (f a, Observe))
-> (RunT f i a -> Valid RunErrors (f a, Observe))
-> RunT f i a
-> Either RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\r :: RunT f i a
r -> RunT f i a -> i -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run RunT f i a
r i
i Observe
forall a. Monoid a => a
mempty)
runWith :: (t -> Valid RunErrors (f a)) -> RunT f t a
runWith :: (t -> Valid RunErrors (f a)) -> RunT f t a
runWith f :: t -> Valid RunErrors (f a)
f = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall a b. (a -> b) -> a -> b
$ \t :: t
t obs :: Observe
obs -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Valid RunErrors (f a)
f t
t
data RunError =
Group Location (Set RunError)
| MatchError Text
| ParseError P.Key String
| RequiredSetting P.Key
| TooFewElements
| TooManyElements
| UnexpectedProperties (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
| UnexpectedSettings (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
deriving (Int -> RunError -> ShowS
[RunError] -> ShowS
RunError -> String
(Int -> RunError -> ShowS)
-> (RunError -> String) -> ([RunError] -> ShowS) -> Show RunError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunError] -> ShowS
$cshowList :: [RunError] -> ShowS
show :: RunError -> String
$cshow :: RunError -> String
showsPrec :: Int -> RunError -> ShowS
$cshowsPrec :: Int -> RunError -> ShowS
Show, RunError -> RunError -> Bool
(RunError -> RunError -> Bool)
-> (RunError -> RunError -> Bool) -> Eq RunError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunError -> RunError -> Bool
$c/= :: RunError -> RunError -> Bool
== :: RunError -> RunError -> Bool
$c== :: RunError -> RunError -> Bool
Eq, Eq RunError
Eq RunError =>
(RunError -> RunError -> Ordering)
-> (RunError -> RunError -> Bool)
-> (RunError -> RunError -> Bool)
-> (RunError -> RunError -> Bool)
-> (RunError -> RunError -> Bool)
-> (RunError -> RunError -> RunError)
-> (RunError -> RunError -> RunError)
-> Ord RunError
RunError -> RunError -> Bool
RunError -> RunError -> Ordering
RunError -> RunError -> RunError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RunError -> RunError -> RunError
$cmin :: RunError -> RunError -> RunError
max :: RunError -> RunError -> RunError
$cmax :: RunError -> RunError -> RunError
>= :: RunError -> RunError -> Bool
$c>= :: RunError -> RunError -> Bool
> :: RunError -> RunError -> Bool
$c> :: RunError -> RunError -> Bool
<= :: RunError -> RunError -> Bool
$c<= :: RunError -> RunError -> Bool
< :: RunError -> RunError -> Bool
$c< :: RunError -> RunError -> Bool
compare :: RunError -> RunError -> Ordering
$ccompare :: RunError -> RunError -> Ordering
$cp1Ord :: Eq RunError
Ord)
instance Exception RunError where
displayException :: RunError -> String
displayException = RunError -> String
forall a. Pretty a => a -> String
prettyString
instance Pretty RunError where
pretty :: RunError -> Doc ann
pretty (Group loc :: Location
loc errors :: Set RunError
errors) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.nest 4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ "Encountered" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
errorNoun Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "in" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Location -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Location
loc
, RunErrors -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Set RunError -> RunErrors
RunErrors Set RunError
errors)
]
where
errorCount :: Int
errorCount = Set RunError -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set RunError
errors
errorNoun :: Doc ann
errorNoun
| Int
errorCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = "an error"
| Bool
otherwise = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
errorCount Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "errors"
pretty (MatchError desc :: Text
desc) =
"Expected" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
desc
pretty (ParseError key :: Key
key msg :: String
msg) =
"Failed to parse setting" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Key -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Key
key Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg
pretty (RequiredSetting key :: Key
key) =
"Node is missing the required setting" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Key -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Key
key
pretty TooFewElements =
"Expected one or more additional nodes within the current context."
pretty TooManyElements =
"Expected no further elements in the current context."
pretty (UnexpectedProperties allowed :: HashSet Key
allowed got :: HashSet Key
got) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.nest 4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ "Encountered at least one unexpected property on the current node."
, "Allowed properties: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Key] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (HashSet Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet Key
allowed)
, "Unexpected properties:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Key] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (HashSet Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet Key
got)
]
pretty (UnexpectedSettings allowed :: HashSet Key
allowed got :: HashSet Key
got) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.nest 4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ "Encountered at least one unexpected setting on the current node."
, "Allowed settings: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Key] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (HashSet Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet Key
allowed)
, "Unexpected settings:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Key] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (HashSet Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet Key
got)
]
newtype RunErrors = RunErrors (Set RunError)
deriving (Int -> RunErrors -> ShowS
[RunErrors] -> ShowS
RunErrors -> String
(Int -> RunErrors -> ShowS)
-> (RunErrors -> String)
-> ([RunErrors] -> ShowS)
-> Show RunErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunErrors] -> ShowS
$cshowList :: [RunErrors] -> ShowS
show :: RunErrors -> String
$cshow :: RunErrors -> String
showsPrec :: Int -> RunErrors -> ShowS
$cshowsPrec :: Int -> RunErrors -> ShowS
Show, RunErrors -> RunErrors -> Bool
(RunErrors -> RunErrors -> Bool)
-> (RunErrors -> RunErrors -> Bool) -> Eq RunErrors
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunErrors -> RunErrors -> Bool
$c/= :: RunErrors -> RunErrors -> Bool
== :: RunErrors -> RunErrors -> Bool
$c== :: RunErrors -> RunErrors -> Bool
Eq, Eq RunErrors
Eq RunErrors =>
(RunErrors -> RunErrors -> Ordering)
-> (RunErrors -> RunErrors -> Bool)
-> (RunErrors -> RunErrors -> Bool)
-> (RunErrors -> RunErrors -> Bool)
-> (RunErrors -> RunErrors -> Bool)
-> (RunErrors -> RunErrors -> RunErrors)
-> (RunErrors -> RunErrors -> RunErrors)
-> Ord RunErrors
RunErrors -> RunErrors -> Bool
RunErrors -> RunErrors -> Ordering
RunErrors -> RunErrors -> RunErrors
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RunErrors -> RunErrors -> RunErrors
$cmin :: RunErrors -> RunErrors -> RunErrors
max :: RunErrors -> RunErrors -> RunErrors
$cmax :: RunErrors -> RunErrors -> RunErrors
>= :: RunErrors -> RunErrors -> Bool
$c>= :: RunErrors -> RunErrors -> Bool
> :: RunErrors -> RunErrors -> Bool
$c> :: RunErrors -> RunErrors -> Bool
<= :: RunErrors -> RunErrors -> Bool
$c<= :: RunErrors -> RunErrors -> Bool
< :: RunErrors -> RunErrors -> Bool
$c< :: RunErrors -> RunErrors -> Bool
compare :: RunErrors -> RunErrors -> Ordering
$ccompare :: RunErrors -> RunErrors -> Ordering
$cp1Ord :: Eq RunErrors
Ord)
instance Exception RunErrors where
displayException :: RunErrors -> String
displayException = RunErrors -> String
forall a. Pretty a => a -> String
prettyString
instance Semigroup RunErrors where
lhs :: RunErrors
lhs@(RunErrors lset :: Set RunError
lset) <> :: RunErrors -> RunErrors -> RunErrors
<> rhs :: RunErrors
rhs@(RunErrors rset :: Set RunError
rset)
| Set RunError -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set RunError
lset = RunErrors
rhs
| Set RunError -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set RunError
rset = RunErrors
lhs
| Bool
otherwise = Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors) -> Set RunError -> RunErrors
forall a b. (a -> b) -> a -> b
$ [RunErrors] -> Set RunError
forall (f :: * -> *). Foldable f => f RunErrors -> Set RunError
combineErrors [RunErrors
lhs, RunErrors
rhs]
sconcat :: NonEmpty RunErrors -> RunErrors
sconcat = Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors)
-> (NonEmpty RunErrors -> Set RunError)
-> NonEmpty RunErrors
-> RunErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty RunErrors -> Set RunError
forall (f :: * -> *). Foldable f => f RunErrors -> Set RunError
combineErrors
instance Monoid RunErrors where
mempty :: RunErrors
mempty = Set RunError -> RunErrors
RunErrors Set RunError
forall a. Monoid a => a
mempty
mconcat :: [RunErrors] -> RunErrors
mconcat = Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors)
-> ([RunErrors] -> Set RunError) -> [RunErrors] -> RunErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunErrors] -> Set RunError
forall (f :: * -> *). Foldable f => f RunErrors -> Set RunError
combineErrors
instance Pretty RunErrors where
pretty :: RunErrors -> Doc ann
pretty = \(RunErrors es :: Set RunError
es) ->
[Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ((Doc ann -> RunError -> Doc ann)
-> [Doc ann] -> [RunError] -> [Doc ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc ann -> RunError -> Doc ann
forall a ann. Pretty a => Doc ann -> a -> Doc ann
combine [Doc ann]
forall ann. [Doc ann]
delims (Set RunError -> [RunError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set RunError
es)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.rbracket
where
delims :: [Doc ann]
delims = Doc ann
forall ann. Doc ann
PP.lbracket Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Doc ann -> [Doc ann]
forall a. a -> [a]
repeat Doc ann
forall ann. Doc ann
PP.comma
combine :: Doc ann -> a -> Doc ann
combine delim :: Doc ann
delim item :: a
item =
Doc ann
delim Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt " " Doc ann
forall a. Monoid a => a
mempty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
item Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.line'
runErrors :: RunErrors -> Set RunError
runErrors :: RunErrors -> Set RunError
runErrors = \(RunErrors es :: Set RunError
es) -> Set RunError
es
failure :: RunError -> Valid RunErrors a
failure :: RunError -> Valid RunErrors a
failure = RunErrors -> Valid RunErrors a
forall e a. e -> Valid e a
Invalid (RunErrors -> Valid RunErrors a)
-> (RunError -> RunErrors) -> RunError -> Valid RunErrors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors)
-> (RunError -> Set RunError) -> RunError -> RunErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunError -> Set RunError
forall a. a -> Set a
Set.singleton
groupErrors :: P.HasLocation t => RunT f t a -> RunT f t a
groupErrors :: RunT f t a -> RunT f t a
groupErrors (RunT f :: t -> Observe -> Valid RunErrors (f a, Observe)
f) = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall a b. (a -> b) -> a -> b
$ \i :: t
i o :: Observe
o ->
case t -> Observe -> Valid RunErrors (f a, Observe)
f t
i Observe
o of
Invalid errors :: RunErrors
errors@(RunErrors errorSet :: Set RunError
errorSet)
| RunErrors -> Bool
shouldWrap RunErrors
errors
, Just loc :: Location
loc <- t
i t -> Getting (First Location) t Location -> Maybe Location
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Location) t Location
forall t. HasLocation t => Affine' t Location
P.location
-> RunErrors -> Valid RunErrors (f a, Observe)
forall e a. e -> Valid e a
Invalid (RunErrors -> Valid RunErrors (f a, Observe))
-> (RunError -> RunErrors)
-> RunError
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors)
-> (RunError -> Set RunError) -> RunError -> RunErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunError -> Set RunError
forall a. a -> Set a
Set.singleton (RunError -> Valid RunErrors (f a, Observe))
-> RunError -> Valid RunErrors (f a, Observe)
forall a b. (a -> b) -> a -> b
$ Location -> Set RunError -> RunError
Group (Location -> Location
Location Location
loc) Set RunError
errorSet
other :: Valid RunErrors (f a, Observe)
other -> Valid RunErrors (f a, Observe)
other
shouldWrap :: RunErrors -> Bool
shouldWrap :: RunErrors -> Bool
shouldWrap (RunErrors es :: Set RunError
es)
| Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = Bool
True
| Bool
otherwise = (RunError -> Bool) -> Set RunError -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case Group{} -> Bool
False; _ -> Bool
True) Set RunError
es
where count :: Int
count = Set RunError -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set RunError
es
combineErrors :: Foldable f => f RunErrors -> Set RunError
combineErrors :: f RunErrors -> Set RunError
combineErrors =
(Set RunError -> Maybe Location -> Set RunError -> Set RunError)
-> Set RunError
-> HashMap (Maybe Location) (Set RunError)
-> Set RunError
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey' Set RunError -> Maybe Location -> Set RunError -> Set RunError
go Set RunError
forall a. Monoid a => a
mempty
(HashMap (Maybe Location) (Set RunError) -> Set RunError)
-> (f RunErrors -> HashMap (Maybe Location) (Set RunError))
-> f RunErrors
-> Set RunError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RunError -> HashMap (Maybe Location) (Set RunError)
forall (f :: * -> *).
Foldable f =>
f RunError -> HashMap (Maybe Location) (Set RunError)
groupGroups
(Set RunError -> HashMap (Maybe Location) (Set RunError))
-> (f RunErrors -> Set RunError)
-> f RunErrors
-> HashMap (Maybe Location) (Set RunError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunErrors -> Set RunError) -> f RunErrors -> Set RunError
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RunErrors -> Set RunError
runErrors
where
go :: Set RunError -> Maybe Location -> Set RunError -> Set RunError
go acc :: Set RunError
acc key :: Maybe Location
key val :: Set RunError
val = Set RunError -> Set RunError -> Set RunError
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set RunError
acc (Set RunError -> Set RunError) -> Set RunError -> Set RunError
forall a b. (a -> b) -> a -> b
$ case Maybe Location
key of
Just loc :: Location
loc -> RunError -> Set RunError
forall a. a -> Set a
Set.singleton (Location -> Set RunError -> RunError
Group (Location -> Location
Location Location
loc) Set RunError
val)
Nothing -> Set RunError
val
groupGroups :: Foldable f => f RunError -> HM.HashMap (Maybe P.Location) (Set RunError)
groupGroups :: f RunError -> HashMap (Maybe Location) (Set RunError)
groupGroups = (HashMap (Maybe Location) (Set RunError)
-> RunError -> HashMap (Maybe Location) (Set RunError))
-> HashMap (Maybe Location) (Set RunError)
-> f RunError
-> HashMap (Maybe Location) (Set RunError)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
(\acc :: HashMap (Maybe Location) (Set RunError)
acc -> \case
Group (Location loc :: Location
loc) e :: Set RunError
e -> (Set RunError -> Set RunError -> Set RunError)
-> Maybe Location
-> Set RunError
-> HashMap (Maybe Location) (Set RunError)
-> HashMap (Maybe Location) (Set RunError)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith Set RunError -> Set RunError -> Set RunError
forall a. Semigroup a => a -> a -> a
(<>) (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc) Set RunError
e HashMap (Maybe Location) (Set RunError)
acc
other :: RunError
other -> (Set RunError -> Set RunError -> Set RunError)
-> Maybe Location
-> Set RunError
-> HashMap (Maybe Location) (Set RunError)
-> HashMap (Maybe Location) (Set RunError)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith Set RunError -> Set RunError -> Set RunError
forall a. Semigroup a => a -> a -> a
(<>) Maybe Location
forall a. Maybe a
Nothing (RunError -> Set RunError
forall a. a -> Set a
Set.singleton RunError
other) HashMap (Maybe Location) (Set RunError)
acc)
HashMap (Maybe Location) (Set RunError)
forall a. Monoid a => a
mempty
newtype Location = Location P.Location
deriving (Int -> Location -> ShowS
[Location] -> ShowS
Location -> String
(Int -> Location -> ShowS)
-> (Location -> String) -> ([Location] -> ShowS) -> Show Location
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Location] -> ShowS
$cshowList :: [Location] -> ShowS
show :: Location -> String
$cshow :: Location -> String
showsPrec :: Int -> Location -> ShowS
$cshowsPrec :: Int -> Location -> ShowS
Show, Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq)
instance Pretty Location where
pretty :: Location -> Doc ann
pretty (Location l :: Location
l) = Location -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Location
l
instance Ord Location where
compare :: Location -> Location -> Ordering
compare = (String, Offset) -> (String, Offset) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((String, Offset) -> (String, Offset) -> Ordering)
-> (Location -> (String, Offset))
-> Location
-> Location
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \(Location loc :: Location
loc) ->
(Source -> String
PS.sourceName (Location -> Source
PS.locationSource Location
loc), Location -> Offset
PS.locationOffset Location
loc)
instance Applicative f => Context (RunT f) where
type Local (RunT f) = f
runSelf :: RunT f i i
runSelf = (i -> Observe -> Valid RunErrors (f i, Observe)) -> RunT f i i
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((i -> Observe -> Valid RunErrors (f i, Observe)) -> RunT f i i)
-> (i -> Observe -> Valid RunErrors (f i, Observe)) -> RunT f i i
forall a b. (a -> b) -> a -> b
$ \t :: i
t obs :: Observe
obs -> (f i, Observe) -> Valid RunErrors (f i, Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (i -> f i
forall (f :: * -> *) a. Applicative f => a -> f a
pure i
t, Observe
obs)
liftRule :: Local (RunT f) a -> RunT f i a
liftRule r :: Local (RunT f) a
r = (i -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f i a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((i -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f i a)
-> (i -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f i a
forall a b. (a -> b) -> a -> b
$ \_ obs :: Observe
obs -> (f a, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
Local (RunT f) a
r, Observe
obs)
instance Applicative f => Interpret (RunT f) P.Block where
runRule :: RuleFor Block (Local (RunT f)) a -> RunT f Block a
runRule = RunT f Block a -> RunT f Block a
forall t (f :: * -> *) a. HasLocation t => RunT f t a -> RunT f t a
groupErrors (RunT f Block a -> RunT f Block a)
-> (BlockRule f a -> RunT f Block a)
-> BlockRule f a
-> RunT f Block a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
BlockRuleBlockTag nested :: Rules BlockTag f a
nested -> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a)
-> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall a b. (a -> b) -> a -> b
$ \block :: Block
block obs :: Observe
obs -> case Block
block of
P.BlockTag tag :: BlockTag
tag -> RunT f BlockTag a
-> BlockTag -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RunT f BlockTag a -> RunT f BlockTag a
forall t (f :: * -> *) a. HasMetadata t => RunT f t a -> RunT f t a
pedantic (RunT f BlockTag a -> RunT f BlockTag a)
-> RunT f BlockTag a -> RunT f BlockTag a
forall a b. (a -> b) -> a -> b
$ Rules BlockTag (Local (RunT f)) a -> RunT f BlockTag a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules BlockTag f a
Rules BlockTag (Local (RunT f)) a
nested) BlockTag
tag Observe
forall a. Monoid a => a
mempty
_ -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "BlockTag"
BlockRuleLiteralTag nested :: Rules LiteralTag f a
nested -> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a)
-> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall a b. (a -> b) -> a -> b
$ \block :: Block
block obs :: Observe
obs -> case Block
block of
P.BlockLiteral tag :: LiteralTag
tag -> RunT f LiteralTag a
-> LiteralTag -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RunT f LiteralTag a -> RunT f LiteralTag a
forall t (f :: * -> *) a. HasMetadata t => RunT f t a -> RunT f t a
pedantic (RunT f LiteralTag a -> RunT f LiteralTag a)
-> RunT f LiteralTag a -> RunT f LiteralTag a
forall a b. (a -> b) -> a -> b
$ Rules LiteralTag (Local (RunT f)) a -> RunT f LiteralTag a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules LiteralTag f a
Rules LiteralTag (Local (RunT f)) a
nested) LiteralTag
tag Observe
forall a. Monoid a => a
mempty
_ -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "BlockLiteral"
BlockRuleParagraph nested :: Rules Paragraph f a
nested -> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a)
-> (Block -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Block a
forall a b. (a -> b) -> a -> b
$ \block :: Block
block obs :: Observe
obs -> case Block
block of
P.BlockParagraph pg :: Paragraph
pg -> RunT f Paragraph a
-> Paragraph -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules Paragraph (Local (RunT f)) a -> RunT f Paragraph a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules Paragraph f a
Rules Paragraph (Local (RunT f)) a
nested) Paragraph
pg Observe
forall a. Monoid a => a
mempty
_ -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "BlockParagraph"
instance Applicative f => Interpret (RunT f) P.Document where
runRule :: RuleFor Document (Local (RunT f)) a -> RunT f Document a
runRule (DocumentRule regionRule) =
(Document -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Document a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Document -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Document a)
-> (Document -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Document a
forall a b. (a -> b) -> a -> b
$ RunT f (Region (Series Block)) a
-> Region (Series Block)
-> Observe
-> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RuleFor (Region (Series Block)) (Local (RunT f)) a
-> RunT f (Region (Series Block)) a
forall (t :: * -> * -> *) i a.
Interpret t i =>
RuleFor i (Local t) a -> t i a
runRule RegionRule (Series Block) f a
RuleFor (Region (Series Block)) (Local (RunT f)) a
regionRule) (Region (Series Block)
-> Observe -> Valid RunErrors (f a, Observe))
-> (Document -> Region (Series Block))
-> Document
-> Observe
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Region (Series Block)
P.documentToRegion
instance Applicative f => Interpret (RunT f) P.Fragment where
runRule :: RuleFor Fragment (Local (RunT f)) a -> RunT f Fragment a
runRule = \case
FragmentRuleLocation callback ->
(Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a)
-> (Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a
forall a b. (a -> b) -> a -> b
$ f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a))
-> (Fragment -> f a) -> Fragment -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (Fragment -> a) -> Fragment -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> a
callback (Maybe Location -> a)
-> (Fragment -> Maybe Location) -> Fragment -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragment -> Maybe Location
P.fragmentLocation
FragmentRuleText callback ->
(Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a)
-> (Fragment -> Valid RunErrors (f a)) -> RunT f Fragment a
forall a b. (a -> b) -> a -> b
$ f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a))
-> (Fragment -> f a) -> Fragment -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (Fragment -> a) -> Fragment -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> a
callback (Text -> a) -> (Fragment -> Text) -> Fragment -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fragment -> Text
P.fragmentText
instance Applicative f => Interpret (RunT f) P.Inline where
runRule :: RuleFor Inline (Local (RunT f)) a -> RunT f Inline a
runRule = \case
InlineRuleBreak item -> (Inline -> Valid RunErrors (f a)) -> RunT f Inline a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Inline -> Valid RunErrors (f a)) -> RunT f Inline a)
-> (Inline -> Valid RunErrors (f a)) -> RunT f Inline a
forall a b. (a -> b) -> a -> b
$ \inline :: Inline
inline -> case Inline
inline of
P.Break -> f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a)) -> f a -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
item
_ -> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "Break"
InlineRuleInlineTag nested -> (Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a)
-> (Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a
forall a b. (a -> b) -> a -> b
$ \inline :: Inline
inline obs :: Observe
obs -> case Inline
inline of
P.InlineTag tag :: InlineTag
tag -> RunT f InlineTag a
-> InlineTag -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RunT f InlineTag a -> RunT f InlineTag a
forall t (f :: * -> *) a. HasMetadata t => RunT f t a -> RunT f t a
pedantic (RunT f InlineTag a -> RunT f InlineTag a)
-> RunT f InlineTag a -> RunT f InlineTag a
forall a b. (a -> b) -> a -> b
$ Rules InlineTag (Local (RunT f)) a -> RunT f InlineTag a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules InlineTag f a
Rules InlineTag (Local (RunT f)) a
nested) InlineTag
tag Observe
forall a. Monoid a => a
mempty
_ -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "InlineTag"
InlineRuleFragment nested -> (Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a)
-> (Inline -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Inline a
forall a b. (a -> b) -> a -> b
$ \inline :: Inline
inline obs :: Observe
obs -> case Inline
inline of
P.InlineText fragment :: Fragment
fragment -> RunT f Fragment a
-> Fragment -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules Fragment (Local (RunT f)) a -> RunT f Fragment a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules Fragment f a
Rules Fragment (Local (RunT f)) a
nested) Fragment
fragment Observe
forall a. Monoid a => a
mempty
_ -> (, Observe
obs) (f a -> (f a, Observe))
-> Valid RunErrors (f a) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Valid RunErrors (f a)
forall a. Text -> Valid RunErrors a
expected "InlineText"
instance Applicative f => Interpret (RunT f) P.Metadata where
runRule :: RuleFor Metadata (Local (RunT f)) a -> RunT f Metadata a
runRule = \case
MetadataRuleProperty callback key ->
Key -> RunT f Metadata ()
forall (f :: * -> *) t. Applicative f => Key -> RunT f t ()
observeProperty Key
key RunT f Metadata () -> RunT f Metadata a -> RunT f Metadata a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(Metadata -> Valid RunErrors (f a)) -> RunT f Metadata a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith (f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a))
-> (Metadata -> f a) -> Metadata -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (Metadata -> a) -> Metadata -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a
callback (Bool -> a) -> (Metadata -> Bool) -> Metadata -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Metadata -> Getting Bool Metadata Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Key -> Lens' Metadata Bool
forall m. HasMetadata m => Key -> Lens' m Bool
P.hasProperty Key
key))
MetadataRuleSetting parse def key ->
Key -> RunT f Metadata ()
forall (f :: * -> *) t. Applicative f => Key -> RunT f t ()
observeSetting Key
key RunT f Metadata () -> RunT f Metadata a -> RunT f Metadata a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(Metadata -> Valid RunErrors (f a)) -> RunT f Metadata a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith (\metadata :: Metadata
metadata ->
case Metadata
metadata Metadata
-> Getting (Maybe Text) Metadata (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Key -> Lens' Metadata (Maybe Text)
forall m. HasMetadata m => Key -> Lens' m (Maybe Text)
P.atSetting Key
key of
Nothing -> Valid RunErrors (f a)
-> (a -> Valid RunErrors (f a)) -> Maybe a -> Valid RunErrors (f a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RunError -> Valid RunErrors (f a)
forall a. RunError -> Valid RunErrors a
failure (RunError -> Valid RunErrors (f a))
-> RunError -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ Key -> RunError
RequiredSetting Key
key) (f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a))
-> (a -> f a) -> a -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Maybe a
def
Just raw :: Text
raw ->
Either RunErrors (f a) -> Valid RunErrors (f a)
forall e a. Either e a -> Valid e a
Valid.fromEither
(Either RunErrors (f a) -> Valid RunErrors (f a))
-> (Either String a -> Either RunErrors (f a))
-> Either String a
-> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> RunErrors)
-> (a -> f a) -> Either String a -> Either RunErrors (f a)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Set RunError -> RunErrors
RunErrors (Set RunError -> RunErrors)
-> (String -> Set RunError) -> String -> RunErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunError -> Set RunError
forall a. a -> Set a
Set.singleton (RunError -> Set RunError)
-> (String -> RunError) -> String -> Set RunError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String -> RunError
ParseError Key
key) a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either String a -> Valid RunErrors (f a))
-> Either String a -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ Text -> Either String a
parse Text
raw)
MetadataRuleAllowUnknown x -> (Metadata -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Metadata a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Metadata -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Metadata a)
-> (Metadata -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Metadata a
forall a b. (a -> b) -> a -> b
$ \_ _ ->
(f a, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x, Observe
NoObserve)
instance Applicative f => Interpret (RunT f) P.Paragraph where
runRule :: RuleFor Paragraph (Local (RunT f)) a -> RunT f Paragraph a
runRule = \case
ParagraphRuleContent nested ->
(Paragraph -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Paragraph a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Paragraph -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Paragraph a)
-> (Paragraph -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f Paragraph a
forall a b. (a -> b) -> a -> b
$ RunT f (SeriesNE Inline) a
-> SeriesNE Inline -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules (SeriesNE Inline) (Local (RunT f)) a
-> RunT f (SeriesNE Inline) a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules (SeriesNE Inline) f a
Rules (SeriesNE Inline) (Local (RunT f)) a
nested) (SeriesNE Inline -> Observe -> Valid RunErrors (f a, Observe))
-> (Paragraph -> SeriesNE Inline)
-> Paragraph
-> Observe
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paragraph -> SeriesNE Inline
P.paragraphContent
ParagraphRuleLocation callback ->
(Paragraph -> Valid RunErrors (f a)) -> RunT f Paragraph a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Paragraph -> Valid RunErrors (f a)) -> RunT f Paragraph a)
-> (Paragraph -> Valid RunErrors (f a)) -> RunT f Paragraph a
forall a b. (a -> b) -> a -> b
$ f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a))
-> (Paragraph -> f a) -> Paragraph -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (Paragraph -> a) -> Paragraph -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> a
callback (Maybe Location -> a)
-> (Paragraph -> Maybe Location) -> Paragraph -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paragraph -> Maybe Location
P.paragraphLocation
instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Region t) where
runRule :: RuleFor (Region t) (Local (RunT f)) a -> RunT f (Region t) a
runRule = \case
RegionRuleContent nested -> (Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a)
-> (Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a
forall a b. (a -> b) -> a -> b
$ \t :: Region t
t obs :: Observe
obs ->
(Observe -> Observe) -> (f a, Observe) -> (f a, Observe)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Observe -> Observe -> Observe
forall a b. a -> b -> a
const Observe
obs)
((f a, Observe) -> (f a, Observe))
-> Valid RunErrors (f a, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules t (Local (RunT f)) a -> RunT f t a
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules t f a
Rules t (Local (RunT f)) a
nested) (Region t -> t
forall a. Region a -> a
P.regionContent Region t
t) Observe
forall a. Monoid a => a
mempty
RegionRuleLocation callback ->
(Region t -> Valid RunErrors (f a)) -> RunT f (Region t) a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Region t -> Valid RunErrors (f a)) -> RunT f (Region t) a)
-> (Region t -> Valid RunErrors (f a)) -> RunT f (Region t) a
forall a b. (a -> b) -> a -> b
$ f a -> Valid RunErrors (f a)
forall e a. a -> Valid e a
Valid.Valid (f a -> Valid RunErrors (f a))
-> (Region t -> f a) -> Region t -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Applicative f => a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure @f (a -> f a) -> (Region t -> a) -> Region t -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> a
callback (Maybe Location -> a)
-> (Region t -> Maybe Location) -> Region t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Region t -> Maybe Location
forall a. Region a -> Maybe Location
P.regionLocation
RegionRuleMetadata rule ->
(Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a)
-> (Region t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Region t) a
forall a b. (a -> b) -> a -> b
$ RunT f Metadata a
-> Metadata -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RuleFor Metadata (Local (RunT f)) a -> RunT f Metadata a
forall (t :: * -> * -> *) i a.
Interpret t i =>
RuleFor i (Local t) a -> t i a
runRule MetadataRule f a
RuleFor Metadata (Local (RunT f)) a
rule) (Metadata -> Observe -> Valid RunErrors (f a, Observe))
-> (Region t -> Metadata)
-> Region t
-> Observe
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Region t -> Metadata
forall a. Region a -> Metadata
P.regionMetadata
instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Tag t) where
runRule :: RuleFor (Tag t) (Local (RunT f)) a -> RunT f (Tag t) a
runRule = \case
TagRuleKey key ret ->
(Tag t -> Valid RunErrors (f a)) -> RunT f (Tag t) a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith
((Tag t -> Valid RunErrors (f a)) -> RunT f (Tag t) a)
-> (Tag t -> Valid RunErrors (f a)) -> RunT f (Tag t) a
forall a b. (a -> b) -> a -> b
$ \tag :: Tag t
tag -> if Tag t -> Key
forall a. Tag a -> Key
P.tagName Tag t
tag Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
key
then f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a)) -> f a -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
else RunError -> Valid RunErrors (f a)
forall a. RunError -> Valid RunErrors a
failure (RunError -> Valid RunErrors (f a))
-> (Text -> RunError) -> Text -> Valid RunErrors (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RunError
MatchError (Text -> Valid RunErrors (f a)) -> Text -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ "rawKey == " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Key -> Text
P.rawKey Key
key)
TagRuleRegion nested -> (Tag t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Tag t) a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Tag t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Tag t) a)
-> (Tag t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Tag t) a
forall a b. (a -> b) -> a -> b
$ RunT f (Region t) a
-> Region t -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RuleFor (Region t) (Local (RunT f)) a -> RunT f (Region t) a
forall (t :: * -> * -> *) i a.
Interpret t i =>
RuleFor i (Local t) a -> t i a
runRule RegionRule t f a
RuleFor (Region t) (Local (RunT f)) a
nested) (Region t -> Observe -> Valid RunErrors (f a, Observe))
-> (Tag t -> Region t)
-> Tag t
-> Observe
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag t -> Region t
forall a. Tag a -> Region a
P.tagToRegion
instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Series t) where
runRule :: RuleFor (Series t) (Local (RunT f)) a -> RunT f (Series t) a
runRule = \case
SeriesRuleNext rule -> (Series t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Series t) a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((Series t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Series t) a)
-> (Series t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (Series t) a
forall a b. (a -> b) -> a -> b
$ \series :: Series t
series -> case Series t
series of
x :: t
x :<: xs :: Series t
xs -> RunT f (SeriesNE t) a
-> SeriesNE t -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (RuleFor (SeriesNE t) (Local (RunT f)) a -> RunT f (SeriesNE t) a
forall (t :: * -> * -> *) i a.
Interpret t i =>
RuleFor i (Local t) a -> t i a
runRule SeriesNERule t f a
RuleFor (SeriesNE t) (Local (RunT f)) a
rule) (t
x t -> Series t -> SeriesNE t
forall a. a -> Series a -> SeriesNE a
:<<: Series t
xs)
Empty -> Valid RunErrors (f a, Observe)
-> Observe -> Valid RunErrors (f a, Observe)
forall a b. a -> b -> a
const (Valid RunErrors (f a, Observe)
-> Observe -> Valid RunErrors (f a, Observe))
-> Valid RunErrors (f a, Observe)
-> Observe
-> Valid RunErrors (f a, Observe)
forall a b. (a -> b) -> a -> b
$ RunError -> Valid RunErrors (f a, Observe)
forall a. RunError -> Valid RunErrors a
failure RunError
TooFewElements
SeriesRuleEmpty ret -> (Series t -> Valid RunErrors (f a)) -> RunT f (Series t) a
forall t (f :: * -> *) a.
(t -> Valid RunErrors (f a)) -> RunT f t a
runWith ((Series t -> Valid RunErrors (f a)) -> RunT f (Series t) a)
-> (Series t -> Valid RunErrors (f a)) -> RunT f (Series t) a
forall a b. (a -> b) -> a -> b
$ \series :: Series t
series -> case Series t
series of
_ :<: _ -> RunError -> Valid RunErrors (f a)
forall a. RunError -> Valid RunErrors a
failure RunError
TooManyElements
Empty -> f a -> Valid RunErrors (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Valid RunErrors (f a)) -> f a -> Valid RunErrors (f a)
forall a b. (a -> b) -> a -> b
$ a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.SeriesNE t) where
runRule :: RuleFor (SeriesNE t) (Local (RunT f)) a -> RunT f (SeriesNE t) a
runRule (SeriesNERule combine rule rules) = (SeriesNE t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (SeriesNE t) a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((SeriesNE t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (SeriesNE t) a)
-> (SeriesNE t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f (SeriesNE t) a
forall a b. (a -> b) -> a -> b
$ \(x :: t
x :<<: xs :: Series t
xs) o :: Observe
o ->
(\(f1 :: f b
f1, o1 :: Observe
o1) (f2 :: f c
f2, o2 :: Observe
o2) -> (b -> c -> a
combine (b -> c -> a) -> f b -> f (c -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
f1 f (c -> a) -> f c -> f a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f c
f2, Observe
o1 Observe -> Observe -> Observe
forall a. Semigroup a => a -> a -> a
<> Observe
o2))
((f b, Observe) -> (f c, Observe) -> (f a, Observe))
-> Valid RunErrors (f b, Observe)
-> Valid RunErrors ((f c, Observe) -> (f a, Observe))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunT f t b -> t -> Observe -> Valid RunErrors (f b, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules t (Local (RunT f)) b -> RunT f t b
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules t f b
Rules t (Local (RunT f)) b
rule) t
x Observe
o
Valid RunErrors ((f c, Observe) -> (f a, Observe))
-> Valid RunErrors (f c, Observe) -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RunT f (Series t) c
-> Series t -> Observe -> Valid RunErrors (f c, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run (Rules (Series t) (Local (RunT f)) c -> RunT f (Series t) c
forall (t :: * -> * -> *) i a.
Interpret t i =>
Rules i (Local t) a -> t i a
interpret Rules (Series t) f c
Rules (Series t) (Local (RunT f)) c
rules) Series t
xs Observe
o
instance Applicative f => Interpret (RunT f) Text
expected :: Text -> Valid RunErrors a
expected :: Text -> Valid RunErrors a
expected = RunError -> Valid RunErrors a
forall a. RunError -> Valid RunErrors a
failure (RunError -> Valid RunErrors a)
-> (Text -> RunError) -> Text -> Valid RunErrors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RunError
MatchError
data Observe =
NoObserve
| Observe !Observing
deriving Int -> Observe -> ShowS
[Observe] -> ShowS
Observe -> String
(Int -> Observe -> ShowS)
-> (Observe -> String) -> ([Observe] -> ShowS) -> Show Observe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Observe] -> ShowS
$cshowList :: [Observe] -> ShowS
show :: Observe -> String
$cshow :: Observe -> String
showsPrec :: Int -> Observe -> ShowS
$cshowsPrec :: Int -> Observe -> ShowS
Show
instance Semigroup Observe where
Observe lhs :: Observing
lhs <> :: Observe -> Observe -> Observe
<> Observe rhs :: Observing
rhs = Observing -> Observe
Observe (Observing
lhs Observing -> Observing -> Observing
forall a. Semigroup a => a -> a -> a
<> Observing
rhs)
NoObserve <> _ = Observe
NoObserve
_ <> NoObserve = Observe
NoObserve
instance Monoid Observe where
mempty :: Observe
mempty = Observe
NoObserve
data Observing = Observing
{ Observing -> HashSet Key
obsProperties :: !(HashSet.HashSet P.Key)
, Observing -> HashSet Key
obsSettings :: !(HashSet.HashSet P.Key)
}
deriving Int -> Observing -> ShowS
[Observing] -> ShowS
Observing -> String
(Int -> Observing -> ShowS)
-> (Observing -> String)
-> ([Observing] -> ShowS)
-> Show Observing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Observing] -> ShowS
$cshowList :: [Observing] -> ShowS
show :: Observing -> String
$cshow :: Observing -> String
showsPrec :: Int -> Observing -> ShowS
$cshowsPrec :: Int -> Observing -> ShowS
Show
instance Semigroup Observing where
Observing a :: HashSet Key
a b :: HashSet Key
b <> :: Observing -> Observing -> Observing
<> Observing z :: HashSet Key
z y :: HashSet Key
y = HashSet Key -> HashSet Key -> Observing
Observing (HashSet Key
a HashSet Key -> HashSet Key -> HashSet Key
forall a. Semigroup a => a -> a -> a
<> HashSet Key
z) (HashSet Key
b HashSet Key -> HashSet Key -> HashSet Key
forall a. Semigroup a => a -> a -> a
<> HashSet Key
y)
instance Monoid Observing where
mempty :: Observing
mempty = HashSet Key -> HashSet Key -> Observing
Observing HashSet Key
forall a. Monoid a => a
mempty HashSet Key
forall a. Monoid a => a
mempty
observeProperty :: Applicative f => P.Key -> RunT f t ()
observeProperty :: Key -> RunT f t ()
observeProperty k :: Key
k = (t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ()
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ())
-> (t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ()
forall a b. (a -> b) -> a -> b
$ \_ o :: Observe
o ->
let
o' :: Observe
o' = case Observe
o of
Observe obs :: Observing
obs -> Observing -> Observe
Observe (Observing -> Observe) -> Observing -> Observe
forall a b. (a -> b) -> a -> b
$ Observing
obs
{ obsProperties :: HashSet Key
obsProperties = Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Key
k (HashSet Key -> HashSet Key) -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ Observing -> HashSet Key
obsProperties Observing
obs }
NoObserve -> Observe
o
in
(f (), Observe) -> Valid RunErrors (f (), Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), Observe
o')
observeSetting :: Applicative f => P.Key -> RunT f t ()
observeSetting :: Key -> RunT f t ()
observeSetting k :: Key
k = (t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ()
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ())
-> (t -> Observe -> Valid RunErrors (f (), Observe)) -> RunT f t ()
forall a b. (a -> b) -> a -> b
$ \_ o :: Observe
o ->
let
o' :: Observe
o' = case Observe
o of
Observe obs :: Observing
obs -> Observing -> Observe
Observe (Observing -> Observe) -> Observing -> Observe
forall a b. (a -> b) -> a -> b
$ Observing
obs
{ obsSettings :: HashSet Key
obsSettings = Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Key
k (HashSet Key -> HashSet Key) -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ Observing -> HashSet Key
obsSettings Observing
obs }
NoObserve -> Observe
o
in
(f (), Observe) -> Valid RunErrors (f (), Observe)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), Observe
o')
pedantic :: P.HasMetadata t => RunT f t a -> RunT f t a
pedantic :: RunT f t a -> RunT f t a
pedantic = (t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
forall (f :: * -> *) t a.
(t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a
RunT ((t -> Observe -> Valid RunErrors (f a, Observe)) -> RunT f t a)
-> (RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f t a
-> RunT f t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Observe -> Valid RunErrors (f a, Observe))
-> t -> Observe -> Valid RunErrors (f a, Observe)
forall s a.
HasMetadata s =>
(s -> Observe -> Valid RunErrors (a, Observe))
-> s -> Observe -> Valid RunErrors (a, Observe)
go ((t -> Observe -> Valid RunErrors (f a, Observe))
-> t -> Observe -> Valid RunErrors (f a, Observe))
-> (RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe))
-> RunT f t a
-> t
-> Observe
-> Valid RunErrors (f a, Observe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
forall (f :: * -> *) t a.
RunT f t a -> t -> Observe -> Valid RunErrors (f a, Observe)
_run
where
check :: s -> Observe -> Valid RunErrors ()
check t :: s
t = \case
Observe (Observing props :: HashSet Key
props settings :: HashSet Key
settings) -> do
let unexpectedProps :: [Key]
unexpectedProps = s
t s -> Getting (Endo [Key]) s Key -> [Key]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Optic (->) (Const (Endo [Key])) s s (Set Key) (Set Key)
forall m. HasMetadata m => Lens' m (Set Key)
P.properties Optic (->) (Const (Endo [Key])) s s (Set Key) (Set Key)
-> ((Key -> Const (Endo [Key]) Key)
-> Set Key -> Const (Endo [Key]) (Set Key))
-> Getting (Endo [Key]) s Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Const (Endo [Key]) Key)
-> Set Key -> Const (Endo [Key]) (Set Key)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded ((Key -> Const (Endo [Key]) Key)
-> Set Key -> Const (Endo [Key]) (Set Key))
-> ((Key -> Const (Endo [Key]) Key)
-> Key -> Const (Endo [Key]) Key)
-> (Key -> Const (Endo [Key]) Key)
-> Set Key
-> Const (Endo [Key]) (Set Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> Traversal' Key Key
forall a. (a -> Bool) -> Traversal' a a
filtered (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> HashSet Key -> Bool) -> HashSet Key -> Key -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashSet Key -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member HashSet Key
props)
unexpectedSettings :: [Key]
unexpectedSettings = s
t s -> Getting (Endo [Key]) s Key -> [Key]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Optic
(->) (Const (Endo [Key])) s s (Assoc Key Text) (Assoc Key Text)
forall m. HasMetadata m => Lens' m (Assoc Key Text)
P.settings Optic
(->) (Const (Endo [Key])) s s (Assoc Key Text) (Assoc Key Text)
-> ((Key -> Const (Endo [Key]) Key)
-> Assoc Key Text -> Const (Endo [Key]) (Assoc Key Text))
-> Getting (Endo [Key]) s Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic
(->)
(Const (Endo [Key]))
(Assoc Key Text)
(Assoc Key Text)
(HashMap Key Text)
(HashMap Key Text)
forall k v k' v'.
Iso (Assoc k v) (Assoc k' v') (HashMap k v) (HashMap k' v')
P._Assoc Optic
(->)
(Const (Endo [Key]))
(Assoc Key Text)
(Assoc Key Text)
(HashMap Key Text)
(HashMap Key Text)
-> ((Key -> Const (Endo [Key]) Key)
-> HashMap Key Text -> Const (Endo [Key]) (HashMap Key Text))
-> (Key -> Const (Endo [Key]) Key)
-> Assoc Key Text
-> Const (Endo [Key]) (Assoc Key Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Key Text -> [Key])
-> SimpleGetter (HashMap Key Text) [Key]
forall s a. (s -> a) -> SimpleGetter s a
to HashMap Key Text -> [Key]
forall k v. HashMap k v -> [k]
HM.keys Getting (Endo [Key]) (HashMap Key Text) [Key]
-> ((Key -> Const (Endo [Key]) Key)
-> [Key] -> Const (Endo [Key]) [Key])
-> (Key -> Const (Endo [Key]) Key)
-> HashMap Key Text
-> Const (Endo [Key]) (HashMap Key Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Const (Endo [Key]) Key)
-> [Key] -> Const (Endo [Key]) [Key]
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded ((Key -> Const (Endo [Key]) Key)
-> [Key] -> Const (Endo [Key]) [Key])
-> ((Key -> Const (Endo [Key]) Key)
-> Key -> Const (Endo [Key]) Key)
-> (Key -> Const (Endo [Key]) Key)
-> [Key]
-> Const (Endo [Key]) [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> Traversal' Key Key
forall a. (a -> Bool) -> Traversal' a a
filtered (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> HashSet Key -> Bool) -> HashSet Key -> Key -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> HashSet Key -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member HashSet Key
settings)
Bool -> Valid RunErrors () -> Valid RunErrors ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
unexpectedProps) (Valid RunErrors () -> Valid RunErrors ())
-> Valid RunErrors () -> Valid RunErrors ()
forall a b. (a -> b) -> a -> b
$
RunError -> Valid RunErrors ()
forall a. RunError -> Valid RunErrors a
failure (HashSet Key -> HashSet Key -> RunError
UnexpectedProperties HashSet Key
props ([Key] -> HashSet Key
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [Key]
unexpectedProps))
Bool -> Valid RunErrors () -> Valid RunErrors ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
unexpectedSettings) (Valid RunErrors () -> Valid RunErrors ())
-> Valid RunErrors () -> Valid RunErrors ()
forall a b. (a -> b) -> a -> b
$
RunError -> Valid RunErrors ()
forall a. RunError -> Valid RunErrors a
failure (HashSet Key -> HashSet Key -> RunError
UnexpectedSettings HashSet Key
settings ([Key] -> HashSet Key
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [Key]
unexpectedSettings))
pure ()
NoObserve ->
() -> Valid RunErrors ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go :: (s -> Observe -> Valid RunErrors (a, Observe))
-> s -> Observe -> Valid RunErrors (a, Observe)
go f :: s -> Observe -> Valid RunErrors (a, Observe)
f t :: s
t obs :: Observe
obs =
let
result :: Valid RunErrors (a, Observe)
result = s -> Observe -> Valid RunErrors (a, Observe)
f s
t (Observe -> Valid RunErrors (a, Observe))
-> Observe -> Valid RunErrors (a, Observe)
forall a b. (a -> b) -> a -> b
$ case Observe
obs of
NoObserve -> Observing -> Observe
Observe Observing
forall a. Monoid a => a
mempty
_ -> Observe
obs
in
Valid RunErrors (a, Observe)
result Valid RunErrors (a, Observe)
-> Valid RunErrors () -> Valid RunErrors (a, Observe)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* case Valid RunErrors (a, Observe)
result of
Valid.Valid (_, o :: Observe
o) -> s -> Observe -> Valid RunErrors ()
forall s. HasMetadata s => s -> Observe -> Valid RunErrors ()
check s
t Observe
o
_ -> () -> Valid RunErrors ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
prettyString :: Pretty a => a -> String
prettyString :: a -> String
prettyString =
SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
PPS.renderString
(SimpleDocStream Any -> String)
-> (a -> SimpleDocStream Any) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty (LayoutOptions
PP.defaultLayoutOptions { layoutPageWidth :: PageWidth
PP.layoutPageWidth = PageWidth
PP.Unbounded })
(Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty