prosidyc 0.2.0.0 → 0.3.0.0

raw patch · 13 files changed

+1245/−978 lines, 13 filesdep +containersdep +prettyprinterdep +profunctorsdep −mtldep ~hashabledep ~prosidyPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, prettyprinter, profunctors

Dependencies removed: mtl

Dependency ranges changed: hashable, prosidy

API changes (from Hackage documentation)

Files

• prosidyc.cabal +19/−14
• src/Data/Either/Valid.hs +79/−0
• src/Data/Void/HKT.hs +89/−0
• src/Prosidy/Compile.hs +5/−103
• src/Prosidy/Compile/Core.hs +6/−280
• src/Prosidy/Compile/Core/Interpret.hs +68/−0
• src/Prosidy/Compile/Core/Rules.hs +291/−0
• src/Prosidy/Compile/DSL.hs +271/−0
• src/Prosidy/Compile/Error.hs +0/−220
• src/Prosidy/Compile/FromSetting.hs +0/−82
• src/Prosidy/Compile/Match.hs +0/−123
• src/Prosidy/Compile/Run.hs +417/−61
• src/Prosidy/Compile/Strict.hs +0/−95

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                prosidyc-version:             0.2.0.0+version:             0.3.0.0 synopsis:            A DSL for processing Prosidy documents. license:             MPL-2.0 license-file:        LICENSE@@ -43,20 +43,25 @@     exposed-modules:         Prosidy.Compile       , Prosidy.Compile.Core-      , Prosidy.Compile.Error-      , Prosidy.Compile.FromSetting-      , Prosidy.Compile.Match-      , Prosidy.Compile.Strict+      , Prosidy.Compile.DSL+      , Prosidy.Compile.Run+      , Data.Either.Valid+      , Data.Void.HKT      other-modules:-        Prosidy.Compile.Run+        Prosidy.Compile.Core.Interpret+      , Prosidy.Compile.Core.Rules      build-depends:-        base                 >= 4.11 && < 5-      , prosidy              >= 1.6  && < 1.7-      , free                 >= 5.1  && < 5.2-      , hashable             >= 1.2  && < 1.4-      , microlens            >= 0.4  && < 0.5-      , mtl                  >= 2.2  && < 2.3-      , text                 >= 1.2  && < 1.3-      , unordered-containers >= 0.2  && < 0.3+        base                 >= 4.11     && < 5+      , containers           >= 0.6      && < 0.7+      , free                 >= 5.1      && < 5.2+      , microlens            >= 0.4      && < 0.5+      , prosidy              >= 1.6.0.2  && < 1.7+      , text                 >= 1.2      && < 1.3+      , unordered-containers >= 0.2      && < 0.3+      , profunctors          >= 5.5      && < 5.6+      , hashable             >= 1.3      && < 1.4+      , prettyprinter        >= 1.6      && < 1.7++-------------------------------------------------------------------------------

@@ -0,0 +1,79 @@+{-|+Module      : Data.Either.Valid+Description : 'Either', but accumulates its errors.+Copyright   : ©2020 James Alexander Feldman-Crough+License     : MPL-2.0+Maintainer  : alex@fldcr.com+-}+{-# LANGUAGE LambdaCase #-}+module Data.Either.Valid +  ( Valid(..)+  , fromEither+  , toEither+  , valid+  ) where++import Data.Bifunctor (Bifunctor(..))+import Control.Applicative (Alternative(..))++-- | Like the 'Either' type, but its instances accumulates its errors. As such,+-- there is no 'Monad' instance for 'Valid'.+--+-- The 'Invalid' constructor takes precedence over 'Valid' when used with+-- classes that combine two values.+--+-- Note: There are a /lot/ of packages that implement this data type, but+-- finding a well-maintained one with minimal dependencies proved difficult.+data Valid e a =+    Invalid !e+  | Valid   !a+  deriving (Eq, Show, Ord)++instance (Semigroup e, Semigroup a) => Semigroup (Valid e a) where+    Valid   lhs   <> Valid   rhs = Valid   (lhs <> rhs)+    Invalid lhs   <> Invalid rhs = Invalid (lhs <> rhs)+    lhs@Invalid{} <> _           = lhs+    _             <> rhs         = rhs+    +instance (Semigroup e, Monoid a) => Monoid (Valid e a) where+    mempty = Valid mempty++instance Bifunctor Valid where+    bimap f g = valid (Invalid . f) (Valid . g)+    {-# INLINABLE bimap #-}++instance Functor (Valid e) where+    fmap = second+    {-# INLINE fmap #-}++instance Semigroup e => Applicative (Valid e) where+    pure = Valid++    Valid   fn  <*> Valid   x     = Valid (fn x)+    Invalid lhs <*> Invalid rhs   = Invalid (lhs <> rhs)+    Invalid lhs <*> _             = Invalid lhs+    _           <*> Invalid rhs   = Invalid rhs++instance Monoid e => Alternative (Valid e) where+    empty = Invalid mempty++    lhs@Valid{} <|> _           = lhs+    Invalid lhs <|> Invalid rhs = Invalid (lhs <> rhs)+    Invalid{}   <|> rhs         = rhs++-- | Convert an 'Either' value to 'Valid'.+fromEither :: Either e a -> Valid e a+fromEither = either Invalid Valid+{-# INLINE fromEither #-}++-- | Convert a 'Valid' value to 'Either'.+toEither :: Valid e a -> Either e a+toEither = valid Left Right+{-# INLINE toEither #-}++-- | Consume a 'Valid' by handling errors and valid values.+valid :: (e -> r) -> (a -> r) -> Valid e a -> r+valid l r = \case+    Invalid e -> l e+    Valid   a -> r a+{-# INLINE valid #-}

@@ -0,0 +1,89 @@+{-|+Module      : Data.Void.HKT+Description : A poly-kinded uninhabited type.+Copyright   : ©2020 James Alexander Feldman-Crough+License     : MPL-2.0+Maintainer  : alex@fldcr.com+-}+{-# OPTIONS_GHC -Wno-unused-binds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+module Data.Void.HKT (Void, Uninhabited(..)) where++import           Data.Profunctor                ( Profunctor(..)+                                                , Strong(..)+                                                , Choice(..)+                                                )+import           Data.Bifunctor                 ( Bifunctor(..) )++-- | A poly-kinded, uninhabited type family.+data family Void :: k++-- | The uninhabited type taking no arguments.+data instance Void++-- | The uninhabited type taking one argument.+newtype instance Void (a :: ka) = Void1 Void++-- | The uninhabited type taking two arguments.+newtype instance Void (a :: ka) (b :: kb) = Void2 Void++-- | The uninhabited type taking three arguments.+newtype instance Void (a :: ka) (b :: kb) (c :: kc) = Void3 Void++-- | Defines uninhabited types.+class Uninhabited a where+    -- | If @a@ is an uninhabited type, we will never receive a value of type+    -- @a@ and thus we can return a value of any type.+    absurd :: a -> b++instance Uninhabited Void where+    absurd = \case {}++instance Uninhabited (Void a) where+    absurd = \case {}++instance Uninhabited (Void a b) where+    absurd = \case {}++instance Uninhabited (Void a b c) where+    absurd = \case {}++instance Functor Void where+    fmap = const absurd++instance Functor (Void a) where+    fmap = const absurd++instance Functor (Void a b) where+    fmap = const absurd++instance Bifunctor Void where+    bimap = const (const absurd)++instance Bifunctor (Void a) where+    bimap = const (const absurd)++instance Profunctor Void where+    dimap = const (const absurd)++instance Profunctor (Void a) where+    dimap = const (const absurd)++instance Strong Void where+    first'  = absurd+    second' = absurd++instance Strong (Void a) where+    first'  = absurd+    second' = absurd++instance Choice Void where+    left'  = absurd+    right' = absurd++instance Choice (Void a) where+    left'  = absurd+    right' = absurd

@@ -1,110 +1,12 @@ {-| Module      : Prosidy.Compile-Description : Compile Prosidy documents into other shapes+Description : Reexport module. You probable want to import this. Copyright   : ©2020 James Alexander Feldman-Crough License     : MPL-2.0 Maintainer  : alex@fldcr.com -}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-module Prosidy.Compile-    ( escapeHatch-    , getContent-    , matchContent-    , optParse-    , prop-    , reqParse-    , traversing-    , self-    , strict-    , RuleT-    , Rule-    , CanMatch-    , Error(..)-    , ErrorSet-    , Error'-    , ErrorSet'-    , FromSetting(..)-    , req-    , opt-    , module Prosidy.Compile.Match-    , module Prosidy.Compile.Run-    )-where--import           Prelude                 hiding ( break )-import           Prosidy.Compile.Core-import           Prosidy.Compile.Error-import           Prosidy.Compile.Match-import           Prosidy.Compile.Run-import           Prosidy.Compile.Strict-import           Prosidy.Compile.FromSetting--import           Data.Text                      ( Text )--import qualified Prosidy                       as P------------------------------------------------------------------------------------ | Access the inner 'Prosidy.Types.Content' of a node.-getContent :: P.HasContent i => RuleT (P.Content i) e f a -> RuleT i e f a-getContent = rule . GetContent---- | Traverse over each item in a node's 'P.Content' via fallible matches.-matchContent-    :: ( Applicative f-       , Traversable t-       , P.HasContent i-       , t x ~ P.Content i-       , CanMatch x-       )-    => Match x e f a-    -> RuleT i e f (t a)-matchContent = getContent . traversing . match---- | Parse an optional setting from a node with attached 'P.Metadata'.-optParse-    :: P.HasMetadata i-    => P.Key-    -> (Text -> Either String a)-    -> RuleT i e f (Maybe a)-optParse key = rule . GetSetting id key---- | Check if a property is set on a node with attached 'P.Metadata'.-prop :: P.HasMetadata i => P.Key -> RuleT i e f Bool-prop = rule . GetProperty id---- | Parse an required setting from a node with attached 'P.Metadata'.-reqParse-    :: P.HasMetadata i => P.Key -> (Text -> Either String a) -> RuleT i e f a-reqParse key = rule . GetRequiredSetting key---- | Lift a 'RuleT' so that it operates on a traversable structure.-traversing :: Traversable t => RuleT i e f a -> RuleT (t i) e f (t a)-traversing = rule . Traverse id id---- | Access the contents of a node.-self :: RuleT i e f i-self = rule $ GetSelf id---- | Do anything you want with a node. This should be used sparingly! The--- actions you perform inside of this function are invisible to inspection.-escapeHatch :: (i -> f (Either (Error e) a)) -> RuleT i e f a-escapeHatch = rule . Lift------------------------------------------------------------------------------------ | Retrieve an optional setting, parsing using its 'FromSetting' instance. -opt :: (FromSetting a, P.HasMetadata i) => P.Key -> RuleT i e f (Maybe a)-opt key = optParse key fromSetting+module Prosidy.Compile (module X) where --- | Retrieve an required setting, parsing using its 'FromSetting' instance. -req :: (FromSetting a, P.HasMetadata i) => P.Key -> RuleT i e f a-req key = reqParse key fromSetting+import           Prosidy.Compile.Core          as X+import           Prosidy.Compile.DSL           as X+import           Prosidy.Compile.Run           as X

@@ -1,286 +1,12 @@ {-|-Module      : Prosidy.Compile.Core-Description : Primitive type definitions and functions.+Module      : Prosidy.Compile.Core.Rule+Description : Basic contextual compilation rules  Copyright   : ©2020 James Alexander Feldman-Crough License     : MPL-2.0 Maintainer  : alex@fldcr.com -}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-module Prosidy.Compile.Core-    ( RuleF(..)-    , RuleT-    , Rule-    , CanMatch(evalPattern, noMatchError)-    , Pattern(..)-    , Interpret-    , BlockRegion-    , InlineRegion-    , LiteralRegion-    , interpretWith-    , evalPatterns-    , rule-    )-where--import           Lens.Micro-import           Prosidy.Compile.Error--import           Prosidy                        ( Key-                                                , HasLocation-                                                , HasMetadata-                                                , HasContent(Content)-                                                )-import           Data.Text                      ( Text )-import           Data.Bifunctor                 ( Bifunctor(..) )-import           Data.List.NonEmpty             ( NonEmpty(..) )-import           Control.Monad.Trans            ( MonadTrans(..) )-import           Data.Functor.Identity          ( Identity )--import qualified Prosidy-import qualified Control.Applicative.Free.Final-                                               as Ap---- | A single compilation rule. Parameterized by the following types:------ * @input@: The type of the Prosidy node that is currently accessible.------ * @error@: Allows users to specify a custom error type to be used for--- throwing errors. 'Data.Void.Void' can be used to rely solely on--- the errors built into this library.------ * @context@: A 'Monad' for performing contextual computation beyond what--- is provided by this library. If additional contextual computation is not--- desired, use 'Data.Functor.Identity.Identity' as the type.------ * @output@: The resulting output type.-newtype RuleT input error context output = RuleT-    (Ap.Ap (RuleF input error context) output)-  deriving (Functor, Applicative)--instance MonadTrans (RuleT input error) where-    lift = rule . Lift . const . fmap Right---- | 'RuleT' without a contextual environment.-type Rule input error = RuleT input error Identity---- | Lifts a 'RuleF' into a 'RuleT'.-rule :: RuleF i e f o -> RuleT i e f o-rule = RuleT . Ap.liftAp---- | The control functor for compiling Prosidy elements. Each action--- corresponds to an action to perform on the @input@ variable.------ See 'RuleT' and 'Rule' for use of this type.-data RuleF input error context output where-    -- | Throw an error.-    Fail-        ::Error error-        -> RuleF input error context output--    -- | Embed a raw action as a rule. Note: Please avoid using this if-    -- possible: it breaks static introspection!-    Lift-        ::(input -> context (Either (Error error) output))-        -> RuleF input error context output--    -- | Given a non-empty list of potential cases, construct a Rule that-    -- processes any items matching at least one of those cases.-    TestMatch-        ::(CanMatch input)-        => NonEmpty (Pattern input error context output)-        -> RuleF input error context output--    Traverse-        ::Traversable t-        => (input -> t i)-        -> (t o -> output)-        -> RuleT i error context o-        -> RuleF input error context output--    -- | When @input@ is a value wrapping some 'Content', enable access to that-    -- 'Content' by wrapping a 'RuleT'.-    GetContent-        ::HasContent input-        => RuleT (Content input) error context output-        -> RuleF input           error context output--    -- | Fetch a property from items with metadata.-    GetProperty-        ::HasMetadata input-        => (Bool -> a)-        -> Key-        -> RuleF input error context a--    -- | Fetch an /optional/ setting from items with metadata.-    GetSetting-        ::HasMetadata input-        => (Maybe x -> output)-        -> Key-        -> (Text -> Either String x)-        -> RuleF input error context output--    -- | Fetch a /required/ setting from items with metadata.-    GetRequiredSetting-        ::HasMetadata input-        => Key-        -> (Text -> Either String output)-        -> RuleF input error context output--    -- | Get the raw text from a 'Text' node.-    GetSelf-        ::(input -> output)-        -> RuleF input error context output--instance Functor context => Functor (RuleF input error context) where-    fmap fn = \case-        Fail      e            -> Fail e-        Lift      lift         -> Lift $ fmap (fmap fn) . lift-        TestMatch matches      -> TestMatch $ fmap (fmap fn) matches-        Traverse f g rule      -> Traverse f (fn . g) rule-        GetContent rule        -> GetContent $ fmap fn rule-        GetProperty k key      -> GetProperty (fn . k) key-        GetSetting k key parse -> GetSetting (fn . k) key parse-        GetRequiredSetting key parse ->-            GetRequiredSetting key (fmap fn . parse)-        GetSelf k -> GetSelf (fn . k)------------------------------------------------------------------------------------ | A (lawless) typeclass for enabling fallible matching on nodes.------ Implementing new instances of this class in library code is *unneccessary*--- and *unsupported*.-class (forall i e. Functor (Pattern t i e), HasLocation t) => CanMatch t where-    -- | A data type representing allowable fallible patterns for @t@.-    data family Pattern t :: * -> (* -> *) -> * -> *--    -- | Information about why a @Pattern@ failed to match.-    data family NoMatch t :: *--    -- | Attempt to match a pattern against a value.-    evalPattern ::-           Applicative g-        => Pattern t error context output-           -- ^ The @Pattern@ to match against-        -> Interpret error context g-           -- ^ An interpreter for evaluating the match.-        -> t-           -- ^ The value to attempt to match against-        -> Either (NoMatch t) (g output)--    -- | Lift a @NoMatch@ error into the 'Error' type.-    noMatchError :: NoMatch t -> Error e--instance CanMatch Prosidy.Block where-    data Pattern Prosidy.Block error context output =-        BlockTagP  Key (RuleT BlockRegion                       error context output)-      | LitTagP    Key (RuleT LiteralRegion                     error context output)-      | ParagraphP     (RuleT (Prosidy.SeriesNE Prosidy.Inline) error context output)-      deriving Functor-    -    data NoMatch Prosidy.Block =-        NoMatchBlockTag  Key-      | NoMatchLitTag    Key-      | NoMatchParagraph--    evalPattern (BlockTagP key rule) = evalPatternWith-        (Prosidy._BlockTag . Prosidy.tagged key)-        (NoMatchBlockTag key)-        rule-    evalPattern (LitTagP key rule) = evalPatternWith-        (Prosidy._BlockLiteral . Prosidy.tagged key)-        (NoMatchLitTag key)-        rule-    evalPattern (ParagraphP rule) = evalPatternWith-        (Prosidy._BlockParagraph . Prosidy.content)-        NoMatchParagraph-        rule--    noMatchError (NoMatchBlockTag key) = ExpectedTag BlockKind key-    noMatchError (NoMatchLitTag   key) = ExpectedTag LiteralKind key-    noMatchError NoMatchParagraph      = ExpectedParagraph--instance CanMatch Prosidy.Inline where-    data Pattern Prosidy.Inline error context output =-        InlineTagP Key (RuleT InlineRegion error context output)-      | BreakP         (RuleT ()           error context output)-      | TextP          (RuleT Text         error context output)-      deriving Functor-    -    data NoMatch Prosidy.Inline =-        NoMatchInlineTag Key-      | NoMatchBreak-      | NoMatchText--    evalPattern (InlineTagP key rule) = evalPatternWith-        (Prosidy._InlineTag . Prosidy.tagged key)-        (NoMatchInlineTag key)-        rule-    evalPattern (TextP rule) =-        evalPatternWith (Prosidy._Text . Prosidy.fragment) NoMatchText rule-    evalPattern (BreakP rule) =-        evalPatternWith Prosidy._Break NoMatchBreak rule--    noMatchError (NoMatchInlineTag key) = ExpectedTag InlineKind key-    noMatchError NoMatchText            = ExpectedText-    noMatchError NoMatchBreak           = ExpectedBreak---- | Match one or more patterns, in sequence, against a value. The result from--- the first successful pattern will be returned. Subsequent matches will not--- be tried.-evalPatterns-    :: (CanMatch i, IsError e, ApErrors e g)-    => NonEmpty (Pattern i e f o)-    -> Interpret e f g-    -> i-    -> g o-evalPatterns (x :| xs) interpret input = either liftError id folded-  where-    folded = foldr (\pat acc -> doEval pat `orElse` acc) (doEval x) xs-    doEval pat =-        first (singleError . noMatchError) $ evalPattern pat interpret input-    orElse lhs@Right{} _          = lhs-    orElse (Left lhs)  (Left rhs) = Left $ lhs <> rhs-    orElse _           rhs        = rhs--evalPatternWith-    :: Applicative g-    => Traversal' i j-    -> e-    -> RuleT j e' f o-    -> Interpret e' f g-    -> i-    -> Either e (g o)-evalPatternWith sel error rule interpret input =-    second (interpretWith rule interpret)-        .  maybe (Left error) Right-        $  input-        ^? sel------------------------------------------------------------------------------------ | Build an interpreter into a functor @g@.-interpretWith :: Applicative g => RuleT i e f a -> Interpret e f g -> i -> g a-interpretWith (RuleT ap) int i = Ap.runAp (int i) ap------------------------------------------------------------------------------------ | Runs a single 'RuleF' into an applicative @g@. Passing this value to--- 'interpretWith' will fully evaluate a 'RuleT' into the same functor.-type Interpret e f g = forall i a . i -> RuleF i e f a -> g a------------------------------------------------------------------------------------ | A 'Prosidy.Types.BlockTag' with the tag name removed.-type BlockRegion = Prosidy.Region (Prosidy.Series Prosidy.Block)---- | An 'Prosidy.Types.InlineTag' with the tag name removed.-type InlineRegion = Prosidy.Region (Prosidy.Series Prosidy.Inline)+module Prosidy.Compile.Core (module X) where --- | A 'Prosidy.Types.LiteralTag' with the tag name removed.-type LiteralRegion = Prosidy.Region Text+import           Prosidy.Compile.Core.Interpret+                                               as X+import           Prosidy.Compile.Core.Rules    as X

@@ -0,0 +1,68 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module      : Prosidy.Compile.Core.Interpret+Description : Internal module declaring the 'Context' and 'Interpret' classes. +Copyright   : ©2020 James Alexander Feldman-Crough+License     : MPL-2.0+Maintainer  : alex@fldcr.com+-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeFamilies #-}+module Prosidy.Compile.Core.Interpret+    ( Context(..)+    , Interpret(..)+    , interpret+    )+where++import           Control.Applicative            ( Alternative )+import           Prosidy.Compile.Core.Rules     ( RuleFor+                                                , Rules+                                                , Rule(..)+                                                , runRules+                                                )+import           Data.Void.HKT                  ( Void+                                                , absurd+                                                )++-- | A base class for interpreters of 'Rules'.+class (forall i. Alternative (t i)) => Context t where+    -- | Access the current focus of an interpreter. This function is similar+    -- in purpose to 'Control.Monad.Trans.Reader.ask'.+    runSelf :: t i i++    -- | A type for expressions that can be lifted by the interpreter.+    --+    -- This type defaults to an uninhabited type. Only override this type+    -- if you intend on overriding 'liftRule', as well.+    type Local t :: * -> *++    -- | Lift an expression of type 'Local' into the interpreter. +    --+    -- By default, 'Local' is left as an uninhabted type and escaping via+    -- 'liftRule' can never happen. Override both 'Local' and 'liftRule' to+    -- permit arbitrary computation.+    liftRule :: Local t a -> t i a++    type Local t = Void t+    default liftRule :: Local t a ~ Void t a => Local t a -> t i a+    liftRule = absurd++-- | Instructs a 'Context' how to interpret a single rule.+class Context t => Interpret t i where+    -- | Evaluate a single rule into the context.+    runRule :: RuleFor i (Local t) a -> t i a++    default runRule :: (RuleFor i ~ Void i) => RuleFor i (Local t) a -> t i a+    runRule = absurd++-- | Evaluate 'Rules' into a contextual interpreter.+interpret :: forall t i a. Interpret t i => Rules i (Local t) a -> t i a+interpret = runRules $ \x -> case x of+    RuleFor r -> runRule r+    Escape  f -> liftRule f+    Self    s -> s <$> runSelf

@@ -0,0 +1,291 @@+{-|+Module      : Prosidy.Compile.Core.Rules+Description : Internal module declaring 'Rules' types and functions.+Copyright   : ©2020 James Alexander Feldman-Crough+License     : MPL-2.0+Maintainer  : alex@fldcr.com+-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+module Prosidy.Compile.Core.Rules+    ( Rules+    , Rule(..)+    , rule+    , local+    , self+    , runRules+    , mapRules+    , hoist++    , HoistRuleFor++    -- * Context-aware ADT rules.+    , RuleFor+    , BlockRule(..)+    , DocumentRule(..)+    , FragmentRule(..)+    , InlineRule(..)+    , MetadataRule(..)+    , ParagraphRule(..)+    , RegionRule(..)+    , SeriesNERule(..)+    , SeriesRule(..)+    , TagRule(..)++    -- * Reëxports+    , Alternative(..)+    )+where++import           Prosidy.Types+import           Prosidy.Source                 ( Location )+import           Data.Void.HKT                  ( Void )+import           Data.Text                      ( Text )++import           Control.Applicative            ( Alternative(..) )+import qualified Control.Alternative.Free.Final+                                               as Alt++-------------------------------------------------------------------------------+-- | A container for building up compilation rules.+--+-- * The type parameter @t@ specifies the /input type/ of these rules. It will+-- almost always be a Prosidy node type, such as 'Document' or 'Tag'.+--+-- * The type parameter @f@ is a contextual functor for implementing custom+-- extensions on top of 'Rules'.+newtype Rules t f a = Rules+  { _runRules :: Alt.Alt (Rule t f) a+  }+  deriving newtype (Functor, Applicative, Alternative, Semigroup, Monoid)++-- | Lift a single rule into the 'Rules' functor.+rule :: RuleFor t f a -> Rules t f a+rule = Rules . Alt.liftAlt . RuleFor++-- | Lift a contextual item into 'Rules'.+local :: Functor f => f a -> Rules t f a+local = Rules . Alt.liftAlt . Escape++-- | Get the currently focused node as a value.+self :: Rules t f t+self = Rules . Alt.liftAlt $ Self id++-- | Given an interpreter which can convert 'Rule's into the functor @g@,+-- convert 'Rules' into the functor @g@.+runRules+    :: Alternative g => (forall b . Rule t f b -> g b) -> Rules t f a -> g a+runRules interpret = Alt.runAlt interpret . _runRules++-- | Map over the contextual functor @f@ in 'Rules'.+hoist :: HoistRuleFor t => (forall b. f b -> g b) -> Rules t f a -> Rules t g a+hoist fToG = Rules . Alt.hoistAlt (hoistRule fToG) . _runRules++-- | Map over 'Rules'.+mapRules+    :: forall a a' t t' f+     . (Functor f, Functor (RuleFor t' f))+    => (forall x . RuleFor t f x -> RuleFor t' f x)+      -- ^ Maps over rules themselves, keeping the context and output types the+      -- same.+    -> (t' -> t)+      -- ^ Maps over the input to rules.+    -> (a -> a')+      -- ^ Maps over the output of rules.+    -> Rules t f a+    -> Rules t' f a'+mapRules f g h (Rules alt) = Rules $ h <$> Alt.hoistAlt (mapRule f g id) alt++-------------------------------------------------------------------------------+-- | An individual 'Rule' in isolation.+data Rule t f a =+    RuleFor (RuleFor t f a)   -- ^ A rule specific to the input type @t@+  | Escape  (f a) -- ^ An escape hatch, allowing arbitrary computation+  | Self    (t -> a)          -- ^ A rule which converts the input type to an output.++instance (Functor f, Functor (RuleFor t f)) => Functor (Rule t f) where+    fmap fn x = case x of+        RuleFor rule -> RuleFor $ fn <$> rule+        Escape  rule -> Escape $ fn <$> rule+        Self    self -> Self $ fn <$> self++hoistRule :: HoistRuleFor t => (forall b. f b -> g b) -> Rule t f a -> Rule t g a+hoistRule f (RuleFor rf) = RuleFor (hoistRuleFor f rf)+hoistRule f (Escape fa)  = Escape (f fa)+hoistRule _ (Self fn)    = Self fn++mapRule+    :: (Functor f, Functor (RuleFor t' f))+    => (forall x . RuleFor t f x -> RuleFor t' f x)+    -> (t' -> t)+    -> (a -> a')+    -> Rule t f a+    -> Rule t' f a'+mapRule f _ h (RuleFor r   ) = RuleFor . fmap h . f $ r+mapRule _ _ h (Escape  es  ) = Escape $ h <$> es+mapRule _ g h (Self    self) = Self $ h . self . g++-------------------------------------------------------------------------------+-- | Defines a relationship between input types and rules specific to those+-- input types.+type family RuleFor t = (rule :: (* -> *) -> * -> *) | rule -> t where+  RuleFor Block        = BlockRule+  RuleFor Document     = DocumentRule+  RuleFor Fragment     = FragmentRule+  RuleFor Inline       = InlineRule+  RuleFor Metadata     = MetadataRule+  RuleFor Paragraph    = ParagraphRule+  RuleFor (Region   a) = RegionRule   a+  RuleFor (Series   a) = SeriesRule   a+  RuleFor (SeriesNE a) = SeriesNERule a+  RuleFor (Tag      a) = TagRule      a+  RuleFor           a  = Void         a++-- | A class defining how to map over the contextual parameter @f@ in a rule for+-- the type @t@.+class HoistRuleFor t where+    hoistRuleFor :: (forall b. f b -> g b) -> RuleFor t f a -> RuleFor t g a++-------------------------------------------------------------------------------+-- | Rules for matching specific types of 'Block' nodes.+data BlockRule f a =+    BlockRuleBlockTag   (Rules BlockTag   f a)+  | BlockRuleLiteralTag (Rules LiteralTag f a)+  | BlockRuleParagraph  (Rules Paragraph  f a)+  deriving stock Functor++instance HoistRuleFor Block where+    hoistRuleFor f = \case+        BlockRuleBlockTag rules -> BlockRuleBlockTag $ hoist f rules+        BlockRuleLiteralTag rules -> BlockRuleLiteralTag $ hoist f rules+        BlockRuleParagraph rules -> BlockRuleParagraph $ hoist f rules++-------------------------------------------------------------------------------+-- | Rules applying to 'Document's.+newtype DocumentRule f a =+    DocumentRule (RegionRule (Series Block) f a)+  deriving newtype Functor++instance HoistRuleFor Document where+    hoistRuleFor f = \case +        DocumentRule r -> DocumentRule $ hoistRuleFor f r++-------------------------------------------------------------------------------+-- | Rules applying to 'Fragment's (i.e. plain text).+data FragmentRule f a =+    FragmentRuleLocation (Maybe Location -> a)+  | FragmentRuleText     (Text           -> a)+  deriving stock Functor++instance HoistRuleFor Fragment where+    hoistRuleFor _ = \case+        FragmentRuleLocation fn -> FragmentRuleLocation fn+        FragmentRuleText fn -> FragmentRuleText fn++-------------------------------------------------------------------------------+-- | Rules for matching specific types of 'Inline' nodes.+data InlineRule f a =+    InlineRuleBreak     a+  | InlineRuleFragment  (Rules Fragment  f a)+  | InlineRuleInlineTag (Rules InlineTag f a)+  deriving stock Functor++instance HoistRuleFor Inline where+    hoistRuleFor f = \case+        InlineRuleBreak a -> InlineRuleBreak a+        InlineRuleFragment rules -> InlineRuleFragment $ hoist f rules+        InlineRuleInlineTag rules -> InlineRuleInlineTag $ hoist f rules++-------------------------------------------------------------------------------+-- | Rules for operating on properties and settings.+data MetadataRule f a =+    MetadataRuleProperty (Bool -> a) Key+  | MetadataRuleSetting  (Text -> Either String a) (Maybe a) Key+  | MetadataRuleAllowUnknown a+  deriving stock Functor++instance HoistRuleFor Metadata where+    hoistRuleFor _ = \case+        MetadataRuleProperty fn key -> MetadataRuleProperty fn key+        MetadataRuleSetting fn def key -> MetadataRuleSetting fn def key+        MetadataRuleAllowUnknown a -> MetadataRuleAllowUnknown a++-------------------------------------------------------------------------------+-- | Rules for accessing paragraphs.+data ParagraphRule f a =+    ParagraphRuleContent  (Rules (SeriesNE Inline) f a)+  | ParagraphRuleLocation (Maybe Location -> a)+  deriving stock Functor++instance HoistRuleFor Paragraph where+    hoistRuleFor f = \case+        ParagraphRuleContent rules -> ParagraphRuleContent $ hoist f rules+        ParagraphRuleLocation fn -> ParagraphRuleLocation fn++-------------------------------------------------------------------------------+-- | Rules for operating on a 'Region'.+data RegionRule t f a =+    RegionRuleLocation (Maybe Location -> a)+  | RegionRuleMetadata (MetadataRule f a)+  | RegionRuleContent  (Rules t f a)+  deriving stock Functor++instance HoistRuleFor t => HoistRuleFor (Region t) where+    hoistRuleFor f = \case+        RegionRuleLocation fn   -> RegionRuleLocation fn+        RegionRuleMetadata rule -> RegionRuleMetadata $ hoistRuleFor f rule+        RegionRuleContent rules -> RegionRuleContent $ hoist f rules++-------------------------------------------------------------------------------+-- | Operates sequentially against a collection of nodes.+data SeriesRule t f a =+    SeriesRuleNext (SeriesNERule t f a)+  | SeriesRuleEmpty a++instance Functor (SeriesRule t f) where+    fmap fn (SeriesRuleNext  rule) = SeriesRuleNext (fmap fn rule)+    fmap fn (SeriesRuleEmpty x   ) = SeriesRuleEmpty (fn x)++instance HoistRuleFor t => HoistRuleFor (Series t) where+    hoistRuleFor f = \case+        SeriesRuleNext rule -> SeriesRuleNext $ hoistRuleFor f rule+        SeriesRuleEmpty a -> SeriesRuleEmpty a++-------------------------------------------------------------------------------+-- | Operates sequentially against a non-empty collection of nodes.+data SeriesNERule t f a =+    forall b c. SeriesNERule (b -> c -> a) (Rules t f b) (Rules (Series t) f c)++instance Functor (SeriesNERule t f) where+    fmap fn (SeriesNERule k rule next) = SeriesNERule (fmap fn . k) rule next++instance HoistRuleFor t => HoistRuleFor (SeriesNE t) where+    hoistRuleFor f = \case+        SeriesNERule k r1 rs -> SeriesNERule k (hoist f r1) (hoist f rs)++-------------------------------------------------------------------------------+-- | Rules for operating on 'Tag's.+data TagRule t f a =+    TagRuleKey Key a+  | TagRuleRegion (RegionRule t f a)+  deriving stock Functor++instance HoistRuleFor t => HoistRuleFor (Tag t) where+    hoistRuleFor f = \case+        TagRuleKey k a -> TagRuleKey k a+        TagRuleRegion rule -> TagRuleRegion $ hoistRuleFor f rule++-------------------------------------------------------------------------------+instance HoistRuleFor Text where+    hoistRuleFor _ = \case

@@ -0,0 +1,271 @@+{-|+Module      : Prosidy.Compile.DSL+Description : An EDSL for declaring 'Prosidy.Compile.Core.Rules'.+Copyright   : ©2020 James Alexander Feldman-Crough+License     : MPL-2.0+Maintainer  : alex@fldcr.com+-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE PatternSynonyms #-}+module Prosidy.Compile.DSL+    ( content+      -- * Series rules+    , (&>)+    , (&>>)+    , folded+    , folded1+    , collect+    , end+    , endWith+      -- * Metadata rules+    , prop+    , req+    , opt+    , lax+      -- * Matchers+    , Match+    , match+    , blockTag+    , inlineTag+    , literalTag+    , paragraph+    , text+    , breakWith+      -- * Get wild with actions+    , local+    , self+    , hoist+      -- * Convenience classes+    , FromSetting(..)+    , RegionLike+    )+where++import qualified Prosidy+import           Prosidy.Types.Series           ( pattern Empty+                                                , pattern (:<:)+                                                , pattern (:<<:)+                                                )+import           Prosidy.Compile.Core+import           Data.Monoid                    ( Alt(..) )+import           Text.Read                      ( readMaybe )+import           Type.Reflection                ( Typeable+                                                , typeRep+                                                )+import           Data.Text                      ( Text )+import qualified Data.Text                     as Text+import qualified Data.Text.Lazy                as Text.Lazy+import           Numeric.Natural                ( Natural )++infixr 3 &>+infixr 1 &>>++-------------------------------------------------------------------------------+-- | Access the inner content of the 'RegionLike' value @t@. +content :: RegionLike t => Rules (Prosidy.Content t) f a -> Rules t f a+content = rule . liftRegionRule . RegionRuleContent++-------------------------------------------------------------------------------+-- | Given a 'Prosidy.Series', perform the rule on the left hand side on the+-- first element of the 'Prosidy.Series', and the rule on the right hand side+-- on all items after the first.+--+-- This can be used to define rules which must be evaluated sequentially.+(&>)+    :: Rules t f a+    -> Rules (Prosidy.Series t) f (Prosidy.Series a)+    -> Rules (Prosidy.Series t) f (Prosidy.Series a)+r &> rs = rule . SeriesRuleNext $ SeriesNERule (:<:) r rs++-- | Like '(&>)', but returns a combined rule which operates on a non-empty+-- series ('Prosidy.SeriesNE').+(&>>)+    :: Rules t f a+    -> Rules (Prosidy.Series t) f (Prosidy.Series a)+    -> Rules (Prosidy.SeriesNE t) f (Prosidy.SeriesNE a)+r &>> rs = rule $ SeriesNERule (:<<:) r rs++-- | Match the end of a 'Prosidy.Series'.+end :: Rules (Prosidy.Series t) f (Prosidy.Series a)+end = endWith Empty++-- | Match the end of a 'Prosidy.Series', returning the provided value.+endWith :: a -> Rules (Prosidy.Series t) f a+endWith = rule . SeriesRuleEmpty++-- | Lift a rule to collect many of that rule in series+collect :: Rules t f a -> Rules (Prosidy.Series t) f (Prosidy.Series a)+collect rules = go+  where+    go = (rules &> go) <|> end++-- | Lift a rule to operate on a 'Prosidy.Series' by folding the results of+-- evaluation against each element into a single result.+folded :: Monoid a => Rules t f a -> Rules (Prosidy.Series t) f a+folded r = go+  where+    go = rule (SeriesRuleNext $ SeriesNERule (<>) r go)+        <|> rule (SeriesRuleEmpty mempty)++-- | Like 'folded', but operates on a non-empty series.    +folded1 :: Monoid a => Rules t f a -> Rules (Prosidy.SeriesNE t) f a+folded1 r = rule $ SeriesNERule (<>) r (folded r)++-------------------------------------------------------------------------------+-- | A class for recursive nodes in a document.+class Prosidy.HasContent t => RegionLike t where+    liftRegionRule :: RegionRule (Prosidy.Content t) f a -> RuleFor t f a++instance RegionLike Prosidy.Document where+    liftRegionRule = DocumentRule++instance RegionLike (Prosidy.Tag t) where+    liftRegionRule = TagRuleRegion++instance RegionLike (Prosidy.Region t) where+    liftRegionRule = id++-- | Check if a 'Prosidy.Metadata' property is set on a node.+prop :: RegionLike t => Prosidy.Key -> Rules t f Bool+prop = rule . liftRegionRule . RegionRuleMetadata . MetadataRuleProperty id++-- | Fetch a /required/ 'Prosidy.Metadata' value from a node, parsing it using+-- the provided function.+reqWith+    :: forall a t f. RegionLike t => (Text -> Either String a) -> Prosidy.Key -> Rules t f a+reqWith parse =+    rule+        . liftRegionRule+        . RegionRuleMetadata+        . MetadataRuleSetting parse Nothing++-- | Fetch a /required/ 'Prosidy.Metadata' setting from a node.+req :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f a+req = reqWith parseSetting++-- | Fetch an /optional/ 'Prosidy.Metadata' value from a node, parsing it using+-- the provided function.+optWith+    :: forall a t f. RegionLike t+    => (Text -> Either String a)+    -> Prosidy.Key+    -> Rules t f (Maybe a)+optWith parse =+    rule . liftRegionRule . RegionRuleMetadata . MetadataRuleSetting+        (fmap Just . parse)+        (Just Nothing)++-- | Fetch an /optional/ 'Prosidy.Metadata' setting from a node.+opt :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f (Maybe a)+opt = optWith parseSetting++-- | Allow unknown properties and settings in this region.+lax :: RegionLike t => Rules t f ()+lax = rule . liftRegionRule . RegionRuleMetadata $ MetadataRuleAllowUnknown ()++-------------------------------------------------------------------------------+-- | A class for values which can be parsed from 'Text'.+class FromSetting a where+    parseSetting :: Text -> Either String a++    default parseSetting :: (Typeable a, Read a) => Text -> Either String a+    parseSetting raw = case readMaybe (Text.unpack raw) of+        Just ok -> Right ok+        Nothing -> Left $ "Failed to parse " <> show raw <> " as type " <> show (typeRep @a)++instance FromSetting Double+instance FromSetting Float+instance FromSetting Int+instance FromSetting Integer+instance FromSetting Natural+instance FromSetting Word++instance FromSetting String where+    parseSetting = Right . Text.unpack++instance FromSetting Text where+    parseSetting = Right+    {-# INLINE parseSetting #-}++instance FromSetting Text.Lazy.Text where+    parseSetting = Right . Text.Lazy.fromStrict+    {-# INLINE parseSetting #-}++-------------------------------------------------------------------------------+-- | A type used to declare alternatives in @do@ notation.+type Match t f a = MatchM t f a ()++data MatchM t f a r = MatchM !(Alt (Rules t f) a) !r++instance Semigroup r => Semigroup (MatchM t a f r) where+    MatchM r a <> MatchM s b = MatchM (r <> s) (a <> b)++instance Monoid r => Monoid (MatchM t a f r) where+    mempty = MatchM mempty mempty++instance Functor (MatchM t f a) where+    fmap fn (MatchM r x) = MatchM r (fn x)++instance Applicative (MatchM t f a) where+    pure = MatchM mempty+    MatchM lhs fn <*> MatchM rhs x = MatchM (lhs <> rhs) (fn x)++instance Monad (MatchM t f a) where+    MatchM lhs x >>= f = let MatchM rhs x' = f x in MatchM (lhs <> rhs) x'++-- | Lifts a 'Match' into 'Rules' by trying each defined pattern, from top to+-- bottom, until a match is found.+match :: Match t f a -> Rules t f a+match (MatchM (Alt r) ()) = r++-- | Match a 'Prosidy.BlockTag' with the proided 'Prosidy.Key'.+blockTag+    :: Functor f+    => Prosidy.Key+    -> Rules Prosidy.BlockRegion f a+    -> Match Prosidy.Block f a+blockTag key = matchRule . BlockRuleBlockTag . tagRule key++-- | Match a 'Prosidy.LiteralTag' with the provided 'Prosidy.Key'.+literalTag+    :: Functor f+    => Prosidy.Key+    -> Rules Prosidy.LiteralRegion f a+    -> Match Prosidy.Block f a+literalTag key = matchRule . BlockRuleLiteralTag . tagRule key++-- | Match a 'Prosidy.InlineTag' with the provided 'Prosidy.Key'.+inlineTag+    :: Functor f+    => Prosidy.Key+    -> Rules Prosidy.InlineRegion f a+    -> Match Prosidy.Inline f a+inlineTag key = matchRule . InlineRuleInlineTag . tagRule key++-- | Match a paragraph which is not enclosed in a tag.+paragraph+    :: Rules (Prosidy.SeriesNE Prosidy.Inline) f a -> Match Prosidy.Block f a+paragraph = matchRule . BlockRuleParagraph . rule . ParagraphRuleContent++-- | Match textual content, transforming it with the provided function.+text :: (Text -> a) -> Match Prosidy.Inline f a+text = matchRule . InlineRuleFragment . rule . FragmentRuleText++-- | Replace inline breaks with the provided vlaue.+breakWith :: a -> Match Prosidy.Inline f a+breakWith = matchRule . InlineRuleBreak++matchRule :: RuleFor t f a -> Match t f a+matchRule = flip MatchM () . Alt . rule++tagRule+    :: Functor f+    => Prosidy.Key+    -> Rules (Prosidy.Region t) f a+    -> Rules (Prosidy.Tag t) f a+tagRule key r =+    rule (TagRuleKey key ()) *> mapRules liftRegionRule Prosidy.tagToRegion id r

@@ -1,220 +0,0 @@-{-|-Module      : Prosidy.Compile.Error-Description : Error definitions and utility functions.-Copyright   : ©2020 James Alexander Feldman-Crough-License     : MPL-2.0-Maintainer  : alex@fldcr.com--}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-module Prosidy.Compile.Error-    ( Error(..)-    , TagKind(..)-    , MetadataKind(..)-    , ErrorSet-    , Error'-    , ErrorSet'-    , IsError-    , ApError(..)-    , ApErrors-    , singleError-    , customError-    , liftError1-    , allErrors-    , groupErrors-    )-where--import           Lens.Micro--import           Control.Exception              ( Exception(..) )-import           Prosidy.Types.Key              ( Key )-import           Prosidy.Source                 ( Line(..)-                                                , Column(..)-                                                , Location-                                                )-import           Prosidy.Optics.Source          ( HasLocation(..)-                                                , line-                                                , column-                                                )-import           Data.HashSet                   ( HashSet-                                                , singleton-                                                )-import           GHC.Generics                   ( Generic )-import           Data.Hashable                  ( Hashable )-import           Data.Typeable                  ( Typeable )-import           Data.Void                      ( Void )-import           Data.Foldable                  ( toList )-import           Data.List.NonEmpty             ( NonEmpty(..)-                                                , nonEmpty-                                                )---- | Similar to 'Control.Monad.Except.MonadError', but without the 'Monad'--- constraint, and without a method to handle errors, only a method to map over--- them.-class Applicative f => ApError e f | f -> e where-    liftError :: e -> f a-    mapError  :: (e -> e) -> f a -> f a---- | A synonym for 'ApError' when the underlying applicative is capable of--- accumulating errors in an 'ErrorSet'.-type ApErrors e = ApError (ErrorSet e)---- | A constraint alias for errors throwable in a context admitting a--- 'ApErrors' instance.-type IsError e = (Exception e, Hashable e, Eq e)---- | A non-empty set of errors.-newtype ErrorSet e =-    ErrorSet (HashSet (Error e))-  deriving stock (Show, Generic, Eq)-  deriving anyclass (Hashable)--instance Exception e => Exception (ErrorSet e) where-    displayException (ErrorSet errors) = mconcat-        [ showString "encountered " <> shows (length errors) <> showString-            " error(s):\n"-        , showString "-----\n"-        , foldMap (\x -> showString (displayException x) . showChar '\n') errors-        ]-        ""--instance IsError e => Semigroup (ErrorSet e) where-    ErrorSet lhs <> ErrorSet rhs = ErrorSet $! lhs <> rhs---- | A type alias for 'ErrorSet's which never contain empty errors.-type ErrorSet' = ErrorSet Void---- | Enumerates the errors thrown when-data Error a =-    Custom a-    -- ^ A custom error, allowing extensibility.-  | ParseError Key String-    -- ^ Thrown when parsing a setting fails.-  | Required Key-    -- ^ Thrown when a setting was required to be set, but wasn't provided.-  | ExpectedTag TagKind Key-    -- ^ Thrown when matching against a 'Prosidy.Tag', and another node was-    -- found, or the input tag's 'Key' didn't match the specified key.-  | ExpectedParagraph-    -- ^ Thrown when matching against paragraph and an unexpected node was-    -- encountered.-  | ExpectedText-    -- ^ Thrown when matching against text and an unexpected node was-    -- encountered.-  | ExpectedBreak-    -- ^ Thrown when matching against an explicit break and an unexpected node-    -- was encountered.-  | EmptyMatch-    -- ^ Thrown when a match has no cases to check against.-  | UnknownMetadata (HashSet (MetadataKind, Key))-    -- ^ Thrown when an unknown property or setting is encountered when-    -- checking that properties and settings conform to strictly known-    -- keys.-  | Group (Maybe Location) (ErrorSet a)-    -- ^ Used to group a set of errors thrown at the same point in a tree.-  deriving (Eq, Show, Generic, Hashable)--instance (Typeable a, Exception a) => Exception (Error a) where-    displayException (Custom a        ) = displayException a--    displayException (ParseError k msg) = mconcat-        [ showString "failed to parse the setting "-        , shows k-        , showString ": "-        , showString msg-        ]-        ""--    displayException EmptyMatch   = "Match provided with no possible cases."--    displayException (Required k) = "missing required setting " <> show k--    displayException (ExpectedTag kind k) =-        "expected a " <> kindstr kind <> " tag with key " <> show k-      where-        kindstr BlockKind   = "block"-        kindstr InlineKind  = "inline"-        kindstr LiteralKind = "literal"--    displayException ExpectedParagraph = "expected a paragrapgh"--    displayException ExpectedText      = "expected plain text"--    displayException ExpectedBreak     = "expected a break"--    displayException (UnknownMetadata xs) =-        showString "One or more invalid metadata items were encountered:"-            <> foldMap showItem xs-            $  ""-      where-        showItem (PropertyKind, key) =-            showChar ' ' <> shows key <> showString " (property)"-        showItem (SettingKind, key) =-            showChar ' ' <> shows key <> showString " (setting)"--    displayException (Group (Just loc) x) = mconcat-        [ showString "error(s) encountered at line "-        , shows (loc ^?! line . to (\(Line n) -> succ n))-        , showString " column "-        , shows (loc ^?! column . to (\(Column n) -> succ n))-        , showString ":\n"-        , foldMap-            (\exn -> showString (displayException exn) <> showChar '\n')-            (allErrors x)-        ]-        ""--    displayException (Group Nothing x) = foldMap-        (\exn -> showString (displayException exn) <> showChar '\n')-        (allErrors x)-        ""---- | A type alias for 'Error's that never throw a custom error.-type Error' = Error Void---- | A marker class for marking which type of tag 'ExpectedTag' was expecting.-data TagKind = BlockKind | InlineKind | LiteralKind-  deriving (Show, Eq, Generic, Hashable)---- | A marker class for marking which type of metadata (settings or property)--- a key corresponds to.-data MetadataKind = PropertyKind | SettingKind-  deriving (Show, Eq, Generic, Hashable)---- | Group errors together, attaching a location if one is available.-groupErrors :: (IsError e, ApErrors e m, HasLocation l) => l -> m a -> m a-groupErrors item = mapError $ \es -> case allErrors es of-    Group Nothing  es' :| [] -> singleError $ Group (item ^? location) es'-    Group (Just _) _   :| [] -> es-    _                        -> singleError $ Group (item ^? location) es---- | Lift a single 'Error' into an 'ErrorSet'.-singleError :: Hashable e => Error e -> ErrorSet e-singleError = ErrorSet . singleton-{-# INLINE singleError #-}---- | Lift a custom error into an 'ErrorSet'.-customError :: Hashable e => e -> ErrorSet e-customError = singleError . Custom-{-# INLINE customError #-}---- | Throw a single error.-liftError1 :: (IsError e, ApErrors e m) => Error e -> m a-liftError1 = liftError . singleError-{-# INLINE liftError1 #-}---- | Return the set of errors in an 'ErrorSet' as a non-empty list.-allErrors :: ErrorSet e -> NonEmpty (Error e)-allErrors (ErrorSet hs) =-    maybe (error "unexpected empty ErrorSet") id . nonEmpty $ toList hs

@@ -1,82 +0,0 @@-{-|-Module      : Prosidy.Compile.FromSetting-Description : Typeclass for parsing values from Prosidy settings.-Copyright   : ©2020 James Alexander Feldman-Crough-License     : MPL-2.0-Maintainer  : alex@fldcr.com--}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-module Prosidy.Compile.FromSetting (FromSetting(..), Sep(..)) where--import           Data.Bifunctor                 ( first )-import           Data.Text                      ( Text )-import           Text.Read                      ( readEither )-import           Type.Reflection                ( Typeable-                                                , typeRep-                                                )-import           GHC.TypeLits                   ( KnownSymbol-                                                , Symbol-                                                , symbolVal'-                                                )-import           GHC.Exts                       ( Proxy#-                                                , proxy#-                                                )--import qualified Data.Text                     as Text-import qualified Data.Text.Lazy                as Text.Lazy---- | A typeclass for parsing Prosidy settings into typed values. A default--- instance exists for all types implementing 'Read'.-class FromSetting a where-    -- | Given a 'Text' value containing the setting, either parse a value-    -- or return an error message explaining why the value is malformed.-    fromSetting :: Text -> Either String a--instance FromSetting [Char] where-    fromSetting = Right . Text.unpack-    {-# INLINE fromSetting #-}--instance FromSetting Text where-    fromSetting = Right-    {-# INLINE fromSetting #-}--instance FromSetting Text.Lazy.Text where-    fromSetting = Right . Text.Lazy.fromStrict-    {-# INLINE fromSetting #-}--instance {-# OVERLAPPABLE #-} (Typeable a, Read a) => FromSetting a where-    fromSetting txt = first err . readEither . Text.unpack $ txt-      where-        err = mconcat-            [ showString "failed to parse the string "-            , shows txt-            , showString " as a value of type "-            , shows (typeRep @a)-            , showString ": "-            ]------------------------------------------------------------------------------------ | A newtype wrapper for reading in a delimited list of values. The @delim@--- parameter is a type-level string specifying the seperator between values.--- It must not be empty, or parsing will fail to terminate.--- --- Sep does not handle escaping or other fancy processing.-newtype Sep (delim :: Symbol) a = Sep { unsep :: [a] }-  deriving (Show, Eq, Semigroup, Monoid, Functor, Applicative, Monad, Foldable)--instance Traversable (Sep delim) where-    traverse f = fmap Sep . traverse f . unsep--instance (KnownSymbol delim, FromSetting a) => FromSetting (Sep delim a) where-    fromSetting =-        fmap Sep-            . traverse fromSetting-            . filter (not . Text.null)-            . Text.splitOn (Text.pack $ symbolVal' (proxy# :: Proxy# delim))

@@ -1,123 +0,0 @@-{-|-Module      : Prosidy.Compile.Match-Description : Fallible pattern rules.-Copyright   : ©2020 James Alexander Feldman-Crough-License     : MPL-2.0-Maintainer  : alex@fldcr.com--}-{-# LANGUAGE DerivingVia #-}-module Prosidy.Compile.Match-    ( -- * DSL for matching cases-      Match-    , MatchM-    , match-    -- ** Specific matchers-    , break-    , breakWith-    , paragraph-    , text--    -- *** Tag matchers which strictly enforce metadata.-    , blockTag-    , inlineTag-    , literalTag--    -- *** Tag matchers which loosely enforce metadata.-    , blockTag'-    , inlineTag'-    , literalTag'-    )-where--import           Prelude                 hiding ( break )-import           Prosidy.Compile.Core-import           Prosidy.Compile.Error-import           Prosidy.Compile.Strict--import           Control.Monad.State            ( StateT(..)-                                                , State-                                                , modify'-                                                , execState-                                                )-import           Data.Monoid                    ( Endo(..) )-import           Data.Text                      ( Text )-import           Data.List.NonEmpty             ( NonEmpty(..) )--import qualified Prosidy                       as P---- | The type of fallible pattern specifications.-type Match i e f a = MatchM i e a f ()---- | A monadic interface for defining fallible patterns. In practice, @r@ will--- always be instantiated to @()@— 'Match' can be more clear.-newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r)-  deriving (Functor, Applicative, Monad)-    via State (Endo [Pattern i e f a])---- | Finalize a 'Match' into a rule. This is often used to offset a match--- block:------ @--- blocktags :: Match Block Void Identity String--- blocktags = match $ do---    ...--- @-match :: (Applicative f, CanMatch i) => Match i e f a -> RuleT i e f a-match (MatchM s) = case appEndo (execState s mempty) [] of-    x : xs -> rule . TestMatch $ x :| xs-    []     -> rule $ Fail EmptyMatch---- | Match against a 'Prosidy.Typs.Break'.-break :: RuleT () e f a -> Match P.Inline e f a-break = put . BreakP---- | Replace all 'Prosidy.Types.Break's with the provided value.-breakWith :: a -> Match P.Inline e f a-breakWith = put . BreakP . pure---- | Match 'Prosidy.Types.Paragraph's in a block context.-paragraph :: RuleT (P.SeriesNE P.Inline) e f a -> Match P.Block e f a-paragraph = put . ParagraphP---- | Match plain 'Text' in an inline context.-text :: RuleT Text e f a -> Match P.Inline e f a-text = put . TextP--put :: Pattern i e f a -> Match i e f a-put x = MatchM $ modify' (<> Endo (x :))------------------------------------------------------------------------------------- | Strict: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.-blockTag-    :: Applicative f => P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a-blockTag key = put . BlockTagP key . strict---- | Strict: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.-inlineTag-    :: Applicative f-    => P.Key-    -> RuleT InlineRegion e f a-    -> Match P.Inline e f a-inlineTag key = put . InlineTagP key . strict---- | Strict: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.-literalTag-    :: Applicative f-    => P.Key-    -> RuleT LiteralRegion e f a-    -> Match P.Block e f a-literalTag key = put . LitTagP key . strict------------------------------------------------------------------------------------ | Lax: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.-blockTag' :: P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a-blockTag' key = put . BlockTagP key---- | Lax: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.-inlineTag' :: P.Key -> RuleT InlineRegion e f a -> Match P.Inline e f a-inlineTag' key = put . InlineTagP key---- | Lax: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.-literalTag' :: P.Key -> RuleT LiteralRegion e f a -> Match P.Block e f a-literalTag' key = put . LitTagP key

@@ -1,85 +1,441 @@ {-| Module      : Prosidy.Compile.Run-Description : Interpretation of compilation rules.-Copyright   : ©2020 James Alexander Feldman-Crough+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 DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-module Prosidy.Compile.Run (run, runM) where+{-# 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           Prosidy.Compile.Core-import           Prosidy.Compile.Error -import           Data.Bifunctor                 ( Bifunctor(..) )+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 qualified Prosidy                       as P+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+  { _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 = rmap++instance Applicative f => Applicative (RunT f t) where+    pure x = RunT $ \_ o -> pure (pure x, o)++    RunT lhs <*> RunT rhs = RunT $ \t obs ->+      let+        combine ~(f, o1) ~(x, o2) = (f <*> x, o1 <> o2)+      in+        combine <$> lhs t obs <*> rhs t obs++instance Applicative f => Alternative (RunT f t) where+    empty = RunT $ \_ _ -> empty++    RunT lhs <|> RunT rhs = RunT $ \t obs ->+        lhs t obs <|> rhs t obs ++instance Functor f => Profunctor (RunT f) where+    dimap f g = RunT . go . _run+      where+        go r t obs = first (fmap g) <$> r (f t) obs++instance Functor f => Strong (RunT f) where+    first' = RunT . go . _run+      where+        go r (t, c) obs = first (fmap (, c)) <$> r t obs+    second' = RunT . go . _run+      where+        go r (c, t) obs = first (fmap (c ,)) <$> r t obs++-- | Run a 'Run' interpreter to completion.+run :: i -> Run i a -> Either RunErrors a+run = (fmap runIdentity .) . runT++-- | Run a 'RunT' interpreter to completion.+runT :: i -> RunT f i a -> Either RunErrors (f a)+runT i = fmap fst . Valid.toEither . (\r -> _run r i mempty)++runWith :: (t -> Valid RunErrors (f a)) -> RunT f t a+runWith f = RunT $ \t obs -> (, obs) <$> f 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 (Show, Eq, Ord)++instance Exception RunError where+    displayException = prettyString++instance Pretty RunError where+    pretty (Group loc errors) = PP.nest 4 $ PP.vsep+        [ "Encountered" <+> errorNoun <+> "in" <+> pretty loc+        , pretty (RunErrors errors)+        ] +      where+        errorCount = length errors+        errorNoun +          | errorCount == 1 = "an error"+          | otherwise       = pretty errorCount <+> "errors"++    pretty (MatchError desc) =+        "Expected" <+> pretty desc++    pretty (ParseError key msg) =+        "Failed to parse setting" <+> pretty key <> ":" <+> pretty msg++    pretty (RequiredSetting key) =+        "Node is missing the required setting" <+> pretty 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 got) = PP.nest 4 $ PP.vsep +        [ "Encountered at least one unexpected property on the current node."+        , "Allowed properties:   " <+> pretty (toList allowed)+        , "Unexpected properties:" <+> pretty (toList got)+        ]++    pretty (UnexpectedSettings allowed got) = PP.nest 4 $ PP.vsep +        [ "Encountered at least one unexpected setting on the current node."+        , "Allowed settings:   " <+> pretty (toList allowed)+        , "Unexpected settings:" <+> pretty (toList 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 (Show, Eq, Ord)++instance Exception RunErrors where+    displayException = prettyString++instance Semigroup RunErrors where+    lhs@(RunErrors lset) <> rhs@(RunErrors rset) +      | null lset = rhs+      | null rset = lhs+      | otherwise = RunErrors $ combineErrors [lhs, rhs]+    sconcat = RunErrors . combineErrors++instance Monoid RunErrors where+    mempty = RunErrors mempty+    mconcat = RunErrors . combineErrors++instance Pretty RunErrors where+    pretty = \(RunErrors es) -> +        mconcat (zipWith combine delims (toList es)) <> PP.rbracket+      where+        delims = PP.lbracket : repeat PP.comma+        combine delim item =+            delim <> PP.flatAlt " " mempty <> pretty item <> PP.line'++runErrors :: RunErrors -> Set RunError+runErrors = \(RunErrors es) -> es++failure :: RunError -> Valid RunErrors a+failure = Invalid . RunErrors . Set.singleton++groupErrors :: P.HasLocation t => RunT f t a -> RunT f t a+groupErrors (RunT f) = RunT $ \i o ->+    case f i o of+        Invalid errors@(RunErrors errorSet)+          | shouldWrap errors +          , Just loc <- i ^? P.location+          -> Invalid . RunErrors . Set.singleton $ Group (Location loc) errorSet+        other -> other++shouldWrap :: RunErrors -> Bool+shouldWrap (RunErrors es) +  | count >= 2 = True+  | otherwise  = any (\case Group{} -> False; _ -> True) es+  where count = length es++combineErrors :: Foldable f => f RunErrors -> Set RunError+combineErrors =+      HM.foldlWithKey' go mempty +    . groupGroups +    . foldMap runErrors+  where+    go acc key val = Set.union acc $ case key of+        Just loc -> Set.singleton (Group (Location loc) val)+        Nothing  -> val++groupGroups :: Foldable f => f RunError -> HM.HashMap (Maybe P.Location) (Set RunError)+groupGroups = foldl' +    (\acc -> \case+        Group (Location loc) e -> HM.insertWith (<>) (Just loc) e acc+        other -> HM.insertWith (<>) Nothing (Set.singleton other) acc)+    mempty+    +newtype Location = Location P.Location+  deriving (Show, Eq)++instance Pretty Location where+    pretty (Location l) = pretty l++instance Ord Location where+    compare = compare `on` \(Location loc) ->+        (PS.sourceName (PS.locationSource loc), PS.locationOffset loc)+ ---------------------------------------------------------------------------------- | Run a 'Rule' against an input, returning a parse result.-run :: IsError e => RuleT i e Identity a -> i -> Either (ErrorSet e) a-run rule = runIdentity . runM rule+instance Applicative f => Context (RunT f) where+    type Local (RunT f) = f --- | Run a 'RuleT' against an input, returning a contextual parse result.-runM-    :: (Applicative context, IsError e)-    => RuleT i e context a-    -> i-    -> context (Either (ErrorSet e) a)-runM rule = (\(Run x) -> x) . runRun rule+    runSelf  = RunT $ \t obs -> pure (pure t, obs)+    liftRule r = RunT $ \_ obs -> pure (r, obs) +instance Applicative f => Interpret (RunT f) P.Block where+    runRule = groupErrors . \case+        BlockRuleBlockTag nested -> RunT $ \block obs -> case block of+            P.BlockTag tag -> _run (pedantic $ interpret nested) tag mempty+            _              -> (, obs) <$> expected "BlockTag"++        BlockRuleLiteralTag nested -> RunT $ \block obs -> case block of+            P.BlockLiteral tag -> _run (pedantic $ interpret nested) tag mempty+            _                  -> (, obs) <$> expected "BlockLiteral"++        BlockRuleParagraph nested -> RunT $ \block obs -> case block of+            P.BlockParagraph pg -> _run (interpret nested) pg mempty+            _                   -> (, obs) <$> expected "BlockParagraph"++instance Applicative f => Interpret (RunT f) P.Document where+    runRule (DocumentRule regionRule) =+        RunT $ _run (runRule regionRule) . P.documentToRegion++instance Applicative f => Interpret (RunT f) P.Fragment where+    runRule = \case+        FragmentRuleLocation callback -> +            runWith $ pure . pure . callback . P.fragmentLocation++        FragmentRuleText callback -> +            runWith $ pure . pure . callback . P.fragmentText++instance Applicative f => Interpret (RunT f) P.Inline where+    runRule = \case+        InlineRuleBreak item -> runWith $ \inline -> case inline of+            P.Break -> pure $ pure item+            _       -> expected "Break"++        InlineRuleInlineTag nested -> RunT $ \inline obs -> case inline of+            P.InlineTag tag -> _run (pedantic $ interpret nested) tag mempty+            _               -> (, obs) <$> expected "InlineTag"++        InlineRuleFragment nested -> RunT $ \inline obs -> case inline of+            P.InlineText fragment -> _run (interpret nested) fragment mempty+            _                     -> (, obs) <$> expected "InlineText"++instance Applicative f => Interpret (RunT f) P.Metadata where+    runRule = \case+        MetadataRuleProperty callback key ->+            observeProperty key *>+            runWith (pure . pure . callback . (^. P.hasProperty key))++        MetadataRuleSetting parse def key -> +            observeSetting key *>+            runWith (\metadata ->+                case metadata ^. P.atSetting key of+                    Nothing -> maybe (failure $ RequiredSetting key) (pure . pure) def+                    Just raw ->+                        Valid.fromEither+                            . bimap (RunErrors . Set.singleton . ParseError key) pure+                            $ parse raw)++        MetadataRuleAllowUnknown x -> RunT $ \_ _ ->+            pure (pure x, NoObserve)++instance Applicative f => Interpret (RunT f) P.Paragraph where+    runRule = \case+        ParagraphRuleContent nested ->+            RunT $ _run (interpret nested) . P.paragraphContent++        ParagraphRuleLocation callback ->+            runWith $ pure . pure . callback . P.paragraphLocation++instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Region t) where+    runRule = \case+        RegionRuleContent nested -> RunT $ \t obs ->+            second (const obs)+            <$> _run (interpret nested) (P.regionContent t) mempty++        RegionRuleLocation callback ->+            runWith $ Valid.Valid . pure @f . callback . P.regionLocation++        RegionRuleMetadata rule ->+            RunT $ _run (runRule rule) . P.regionMetadata++instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Tag t) where+    runRule = \case+        TagRuleKey key ret ->+            runWith+                $ \tag -> if P.tagName tag == key+                      then pure $ pure ret+                      else failure . MatchError $ "rawKey == " <> Text.pack (show $ P.rawKey key)++        TagRuleRegion nested -> RunT $ _run (runRule nested) . P.tagToRegion++instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Series t) where+    runRule = \case+        SeriesRuleNext rule -> RunT $ \series -> case series of+            x :<: xs -> _run (runRule rule) (x :<<: xs)+            Empty    -> const $ failure TooFewElements++        SeriesRuleEmpty ret -> runWith $ \series -> case series of+            _ :<: _ -> failure TooManyElements+            Empty   -> pure $ pure ret++instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.SeriesNE t) where+    runRule (SeriesNERule combine rule rules) = RunT $ \(x :<<: xs) o ->+        (\(f1, o1) (f2, o2) -> (combine <$> f1 <*> f2, o1 <> o2))+            <$> _run (interpret rule) x o+            <*> _run (interpret rules) xs o++instance Applicative f => Interpret (RunT f) Text++expected :: Text -> Valid RunErrors a+expected = failure . MatchError+ --------------------------------------------------------------------------------newtype Run error context output = Run-    (context (Either (ErrorSet error) output))-  deriving Functor+data Observe = +    NoObserve+  | Observe !Observing+  deriving Show -instance (Applicative context, IsError error) => Applicative (Run error context) where-    pure = Run . pure . Right-    {-# INLINE pure #-}+instance Semigroup Observe where+    Observe lhs <> Observe rhs = Observe (lhs <> rhs)+    NoObserve <> _ = NoObserve+    _ <> NoObserve = NoObserve -    Run lhsF <*> Run rhsF = Run $ do-        lhs <- lhsF-        rhs <- rhsF-        pure $ either (\es -> Left $ either (es <>) (const es) rhs)-                      (\fn -> second fn rhs)-                      lhs+instance Monoid Observe where+    mempty = NoObserve -instance (Applicative context, IsError error) => ApError (ErrorSet error) (Run error context) where-    liftError = Run . pure . Left-    {-# INLINE liftError #-}+data Observing = Observing+  { obsProperties :: !(HashSet.HashSet P.Key)+  , obsSettings :: !(HashSet.HashSet P.Key)+  }+  deriving Show -    mapError f (Run r) = Run $ fmap (first f) r+instance Semigroup Observing where+    Observing a b <> Observing z y = Observing (a <> z) (b <> y) -runRun-    :: (Applicative context, IsError e)-    => RuleT i e context a-    -> i-    -> Run e context a-runRun rule = interpretWith rule interpret+instance Monoid Observing where+    mempty = Observing mempty mempty -interpret-    :: (Applicative context, IsError error)-    => Interpret error context (Run error context)-interpret input = \case-    Fail e      -> liftError1 e-    Lift lifted -> Run . fmap (first singleError) $ lifted input-    TestMatch matches ->-        groupErrors input $ evalPatterns matches interpret input-    Traverse f g rule -> do-        fmap g . traverse (runRun rule) $ f input-    GetContent rule   -> runRun rule $ input ^. P.content-    GetProperty k key -> input ^. P.hasProperty key & pure . k-    GetSetting k key parse ->-        input ^. P.atSetting key & traverse parse & either-            (liftError1 . ParseError key)-            (pure . k)-    GetRequiredSetting key parse -> do-        input ^. P.atSetting key & maybe-            (liftError1 $ Required key)-            (either (liftError1 . ParseError key) pure . parse)-    GetSelf k -> pure $ k input+observeProperty :: Applicative f => P.Key -> RunT f t ()+observeProperty k = RunT $ \_ o -> +  let+    o' = case o of+        Observe obs -> Observe $ obs +            { obsProperties = HashSet.insert k $ obsProperties obs }+        NoObserve -> o+  in+    pure (pure (), o')++observeSetting :: Applicative f => P.Key -> RunT f t ()+observeSetting k = RunT $ \_ o -> +  let+    o' = case o of+        Observe obs -> Observe $ obs +            { obsSettings = HashSet.insert k $ obsSettings obs }+        NoObserve -> o+  in+    pure (pure (), o')++pedantic :: P.HasMetadata t => RunT f t a -> RunT f t a+pedantic = RunT . go . _run+  where+    check t = \case+        Observe (Observing props settings) -> do+            let unexpectedProps = t ^.. P.properties . folded . filtered (not . flip HashSet.member props)+                unexpectedSettings = t ^.. P.settings . P._Assoc . to HM.keys . folded . filtered (not . flip HashSet.member settings)+            unless (null unexpectedProps) $+                failure (UnexpectedProperties props (HashSet.fromList unexpectedProps))+            unless (null unexpectedSettings) $+                failure (UnexpectedSettings settings (HashSet.fromList unexpectedSettings))+            pure ()++        NoObserve -> +            pure ()++    go f t obs = +      let+        result = f t $ case obs of+            NoObserve -> Observe mempty+            _         -> obs+      in+        result <* case result of+            Valid.Valid (_, o) -> check t o+            _ -> pure ()++-------------------------------------------------------------------------------+prettyString :: Pretty a => a -> String+prettyString = +    PPS.renderString+        . PP.layoutPretty (PP.defaultLayoutOptions { PP.layoutPageWidth = PP.Unbounded }) +        . pretty

@@ -1,95 +0,0 @@-{-|-Module      : Prosidy.Compile.Strict-Description : Ensure that no unknown settings or properties are used.-Copyright   : ©2020 James Alexander Feldman-Crough-License     : MPL-2.0-Maintainer  : alex@fldcr.com--}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-}-module Prosidy.Compile.Strict (strict) where--import           Lens.Micro              hiding ( strict )--import qualified Prosidy                       as P-import           Prosidy.Compile.Core-import           Prosidy.Compile.Error--import           Control.Monad                  ( unless )-import           Data.HashSet                   ( HashSet )--import qualified Data.HashSet                  as HS-import qualified Data.HashMap.Strict           as HM---- | Ensure that all properties and settings on a node are expected, and throw--- an error when extraneous metadata is attached. This is extremely useful--- for catching typos.------ The matchers 'Prosidy.Compile.Match.blockTag', --- 'Prosidy.Compile.Match.inlineTag', and 'Prosidy.Compile.Match.literalTag'--- already match strictly: wrapping them in this combinator is unneccessary.-strict :: (Applicative f, P.HasMetadata i) => RuleT i e f a -> RuleT i e f a-strict r = r <* checked-  where-    checked = rule . Lift $ \item ->-        let-            Schema { schemaProperties, schemaSettings } = collectSchema r item-            extraProperties =-                HS.difference (item ^. P.properties . P._Set) schemaProperties-            extraSettings = HS.difference-                (item ^. P.settings . P._Assoc . to HM.keysSet)-                schemaSettings-            extras =-                HS.map (PropertyKind, ) extraProperties-                    <> HS.map (SettingKind, ) extraSettings-        in-            pure $ unless (HS.null extras) (Left $ UnknownMetadata extras)--collectSchema :: RuleT i e f a -> i -> Schema-collectSchema rule = getSchema . interpretWith rule interpret--interpret :: Interpret e f Strict-interpret _ = \case-    GetProperty _ name        -> recordProperty name-    GetSetting _ name _       -> recordSetting name-    GetRequiredSetting name _ -> recordSetting name-    _                         -> doNothing--newtype Strict a = Strict (Schema -> Schema)--instance Functor Strict where-    fmap _ = coerce--instance Applicative Strict where-    pure _ = Strict id-    Strict lhs <*> Strict rhs = Strict $ lhs <> rhs--data Schema = Schema-    { schemaProperties :: HashSet P.Key-    , schemaSettings   :: HashSet P.Key-    }--instance Semigroup Schema where-    Schema p1 s1 <> Schema p2 s2 = Schema (p1 <> p2) (s1 <> s2)--instance Monoid Schema where-    mempty = Schema mempty mempty--coerce :: Strict a -> Strict b-coerce = \(Strict x) -> Strict x--getSchema :: Strict a -> Schema-getSchema (Strict x) = x mempty--doNothing :: Strict a-doNothing = Strict id--recordProperty :: P.Key -> Strict a-recordProperty k =-    Strict $ \s -> s { schemaProperties = HS.insert k $ schemaProperties s }--recordSetting :: P.Key -> Strict a-recordSetting k =-    Strict $ \s -> s { schemaSettings = HS.insert k $ schemaSettings s }