prosidyc 0.1.0.0 → 0.2.0.0

raw patch · 10 files changed

+383/−88 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +7/−0
• README.pro +1/−1
• prosidyc.cabal +4/−2
• src/Prosidy/Compile.hs +31/−6
• src/Prosidy/Compile/Core.hs +11/−16
• src/Prosidy/Compile/Error.hs +69/−24
• src/Prosidy/Compile/FromSetting.hs +82/−0
• src/Prosidy/Compile/Match.hs +50/−18
• src/Prosidy/Compile/Run.hs +33/−21
• src/Prosidy/Compile/Strict.hs +95/−0

@@ -1,2 +1,9 @@+# v0.2.0.0 _(2020-03-06)_+- Added a typeclass, `FromSetting`, which parses setting strings into values.+- Added a `strict` combinator to check that all metadata items are expected.+- Weakened constraints on `Match` and `Rule` to require `Applicative` instead+  of `Monad`.+- Fixed `Rule` to accumulate all errors.+ # v0.1.0.0 _(2020-03-03)_ - Initial version

@@ -1,7 +1,7 @@ title: prosidyc --- -#lit{prosidyc} is a Haskell library for compiling +#lit{prosidyc} is a Haskell library for compiling #link[uri='https://prosidy.org']{Prosidy} documents into other formats with less of the ceremony of explicit #lit{case ... of} clauses. 

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                prosidyc-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A DSL for processing Prosidy documents. license:             MPL-2.0 license-file:        LICENSE@@ -15,7 +15,7 @@   , GHC == 8.8.1  description:-    A small, Haskell EDSL which builds a specification and compiler for +    A small, Haskell EDSL which builds a specification and compiler for     Prosidy dialects.  source-repository head@@ -44,7 +44,9 @@         Prosidy.Compile       , Prosidy.Compile.Core       , Prosidy.Compile.Error+      , Prosidy.Compile.FromSetting       , Prosidy.Compile.Match+      , Prosidy.Compile.Strict      other-modules:         Prosidy.Compile.Run

@@ -5,15 +5,19 @@ License     : MPL-2.0 Maintainer  : alex@fldcr.com -}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-} {-# 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-    ( -- * Accessors-      escapeHatch+    ( escapeHatch     , getContent     , matchContent     , optParse@@ -21,12 +25,17 @@     , reqParse     , traversing     , self-    -- * Reëxports+    , strict     , RuleT     , Rule     , CanMatch     , Error(..)     , ErrorSet+    , Error'+    , ErrorSet'+    , FromSetting(..)+    , req+    , opt     , module Prosidy.Compile.Match     , module Prosidy.Compile.Run     )@@ -37,6 +46,8 @@ import           Prosidy.Compile.Error import           Prosidy.Compile.Match import           Prosidy.Compile.Run+import           Prosidy.Compile.Strict+import           Prosidy.Compile.FromSetting  import           Data.Text                      ( Text ) @@ -49,7 +60,12 @@  -- | Traverse over each item in a node's 'P.Content' via fallible matches. matchContent-    :: (Traversable t, P.HasContent i, t x ~ P.Content i, CanMatch x)+    :: ( 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@@ -83,3 +99,12 @@ -- 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++-- | 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

@@ -42,7 +42,6 @@ import           Data.Text                      ( Text ) import           Data.Bifunctor                 ( Bifunctor(..) ) import           Data.List.NonEmpty             ( NonEmpty(..) )-import           Control.Monad.Except           ( runExceptT ) import           Control.Monad.Trans            ( MonadTrans(..) ) import           Data.Functor.Identity          ( Identity ) @@ -51,10 +50,10 @@                                                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 +-- * @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. --@@ -77,7 +76,7 @@ rule :: RuleF i e f o -> RuleT i e f o rule = RuleT . Ap.liftAp --- | The control functor for compiling Prosidy elements. Each action +-- | 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.@@ -143,11 +142,10 @@  instance Functor context => Functor (RuleF input error context) where     fmap fn = \case-        Fail      error        -> Fail error+        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@@ -239,22 +237,19 @@ -- the first successful pattern will be returned. Subsequent matches will not -- be tried. evalPatterns-    :: (CanMatch i, IsError e, MonadErrors e g)+    :: (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 =-    runExceptT folded >>= either throwError pure+evalPatterns (x :| xs) interpret input = either liftError id folded   where     folded = foldr (\pat acc -> doEval pat `orElse` acc) (doEval x) xs-    doEval pat = either (throwError1 . noMatchError) lift-        $ evalPattern pat interpret input-    orElse lhsM rhsM = do-        lhs <- lift $ runExceptT lhsM-        case lhs of-            Right ok  -> pure ok-            Left  err -> rhsM `catchError` \err' -> throwError $ err <> err'+    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

@@ -5,27 +5,33 @@ 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-    , MonadErrors+    , ApError(..)+    , ApErrors     , singleError     , customError-    , throwError1+    , liftError1     , allErrors-    , attachLocation-    , MonadError(..)+    , groupErrors     ) where @@ -44,9 +50,6 @@ import           Data.HashSet                   ( HashSet                                                 , singleton                                                 )-import           Control.Monad.Except           ( MonadError(..)-                                                , throwError-                                                ) import           GHC.Generics                   ( Generic ) import           Data.Hashable                  ( Hashable ) import           Data.Typeable                  ( Typeable )@@ -56,26 +59,43 @@                                                 , nonEmpty                                                 ) --- | A contraint alias for types returning at least one error.-type MonadErrors e = MonadError (ErrorSet e)+-- | 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 constraint alias for errors throwable in a context admitting a --- 'MonadErrors' instance.+-- | 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. +-- | 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 +-- | Enumerates the errors thrown when data Error a =     Custom a     -- ^ A custom error, allowing extensibility.@@ -84,7 +104,7 @@   | 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 +    -- ^ 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@@ -97,9 +117,12 @@     -- 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.-    -- If a location is available, we attach it for debugging.   deriving (Eq, Show, Generic, Hashable)  instance (Typeable a, Exception a) => Exception (Error a) where@@ -118,14 +141,28 @@     displayException (Required k) = "missing required setting " <> show k      displayException (ExpectedTag kind k) =-        "expected a " <> show kind <> " tag with key " <> show 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 ExpectedParagraph = "expected a paragrapgh" -    displayException ExpectedText         = "expected plain text"+    displayException ExpectedText      = "expected plain text" -    displayException ExpectedBreak        = "expected a break"+    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))@@ -150,9 +187,17 @@ 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.-attachLocation :: (IsError e, MonadErrors e m, HasLocation l) => l -> m a -> m a-attachLocation item = flip catchError $ throwError1 . Group (item ^? location)+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@@ -165,9 +210,9 @@ {-# INLINE customError #-}  -- | Throw a single error.-throwError1 :: Hashable e => MonadErrors e m => Error e -> m a-throwError1 = throwError . singleError-{-# INLINE throwError1 #-}+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)

@@ -0,0 +1,82 @@+{-|+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))

@@ -14,17 +14,25 @@     -- ** Specific matchers     , break     , breakWith-    , blocktag-    , inlinetag-    , literaltag     , 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@@ -51,10 +59,10 @@ -- -- @ -- blocktags :: Match Block Void Identity String--- blocktags = match $ do +-- blocktags = match $ do --    ... -- @-match :: CanMatch i => Match i e f a -> RuleT i e f a+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@@ -67,19 +75,7 @@ breakWith :: a -> Match P.Inline e f a breakWith = put . BreakP . pure --- | 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---- | 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---- | 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---- | Match 'Prosidy.Types.Paragraph's in a block context. +-- | 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 @@ -89,3 +85,39 @@  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

@@ -5,18 +5,17 @@ License     : MPL-2.0 Maintainer  : alex@fldcr.com -}-{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Prosidy.Compile.Run (run, runM) where  import           Lens.Micro import           Prosidy.Compile.Core import           Prosidy.Compile.Error -import           Control.Monad.Trans            ( MonadIO(..)-                                                , MonadTrans(..)-                                                )-import           Control.Monad.Except           ( ExceptT(..) )+import           Data.Bifunctor                 ( Bifunctor(..) ) import           Data.Functor.Identity          ( Identity(..) )  import qualified Prosidy                       as P@@ -28,7 +27,7 @@  -- | Run a 'RuleT' against an input, returning a contextual parse result. runM-    :: (Monad context, IsError e)+    :: (Applicative context, IsError e)     => RuleT i e context a     -> i     -> context (Either (ErrorSet e) a)@@ -37,37 +36,50 @@ ------------------------------------------------------------------------------- newtype Run error context output = Run     (context (Either (ErrorSet error) output))-  deriving (Functor, Applicative, Monad, MonadError (ErrorSet error))-    via (ExceptT (ErrorSet error) context)+  deriving Functor -instance MonadIO context => MonadIO (Run error context) where-    liftIO = lift . liftIO+instance (Applicative context, IsError error) => Applicative (Run error context) where+    pure = Run . pure . Right+    {-# INLINE pure #-} -instance MonadTrans (Run error) where-    lift = Run . fmap Right+    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 (Applicative context, IsError error) => ApError (ErrorSet error) (Run error context) where+    liftError = Run . pure . Left+    {-# INLINE liftError #-}++    mapError f (Run r) = Run $ fmap (first f) r+ runRun-    :: (Monad context, IsError e) => RuleT i e context a -> i -> Run e context a+    :: (Applicative context, IsError e)+    => RuleT i e context a+    -> i+    -> Run e context a runRun rule = interpretWith rule interpret  interpret-    :: (Monad context, IsError error)+    :: (Applicative context, IsError error)     => Interpret error context (Run error context) interpret input = \case-    Fail e      -> throwError1 e-    Lift lifted -> lift (lifted input) >>= either throwError1 pure+    Fail e      -> liftError1 e+    Lift lifted -> Run . fmap (first singleError) $ lifted input     TestMatch matches ->-        attachLocation input $ evalPatterns matches interpret input+        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-            (throwError1 . ParseError key)+            (liftError1 . ParseError key)             (pure . k)     GetRequiredSetting key parse -> do-        raw <--            input ^. P.atSetting key & maybe (throwError1 $ Required key) pure-        either (throwError1 . ParseError key) pure $ parse raw+        input ^. P.atSetting key & maybe+            (liftError1 $ Required key)+            (either (liftError1 . ParseError key) pure . parse)     GetSelf k -> pure $ k input

@@ -0,0 +1,95 @@+{-|+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 }