{-|
Module      : Prosidy.Compile.Run
Description : A basic intepreter for 'Prosidy.Compile.Core.Rules'.
Copyrighr   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# 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

-- | 'RunT' specialized to 'Identity'.
type Run = RunT Identity

-- | An interpreter over 'Rules'.
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) }
--   deriving (Functor, Applicative) via Compose ((->) t) (Compose (Result RunError) _)

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 a 'Run' interpreter to completion.
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

-- | Run a 'RunT' interpreter to completion.
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

-- | Errors that may be returned from the interpreter.
data RunError =
    Group Location (Set RunError)
    -- ^ Groups a set of errors with a location for more helpful error 
    -- messages.
  | MatchError Text
    -- ^ Expected a different type. Thrown on failed matches of sum types.
  | ParseError P.Key String
    -- ^ The provided parser failed to parse a setting.
  | RequiredSetting P.Key
    -- ^ A setting was required, but not found on a node.
  | TooFewElements
    -- ^ Expected more elements when matching sequentially.
  | TooManyElements
    -- ^ Expected fewer elements when matching sequentially.
  | UnexpectedProperties (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
    -- ^ A property was found on a node, but not mentioned in its specification.
  | UnexpectedSettings (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
    -- ^ A setting was found on a node, but not mentioned in its specification.
  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)
        ]

-- | A newtype wrapper over a set of 'RunError's. 
--
-- This is defined to allow an instances of 'Exception' and 'Pretty' for error
-- sets.
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