diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/README.pro b/README.pro --- a/README.pro +++ b/README.pro @@ -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. diff --git a/prosidyc.cabal b/prosidyc.cabal --- a/prosidyc.cabal +++ b/prosidyc.cabal @@ -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 diff --git a/src/Prosidy/Compile.hs b/src/Prosidy/Compile.hs --- a/src/Prosidy/Compile.hs +++ b/src/Prosidy/Compile.hs @@ -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 diff --git a/src/Prosidy/Compile/Core.hs b/src/Prosidy/Compile/Core.hs --- a/src/Prosidy/Compile/Core.hs +++ b/src/Prosidy/Compile/Core.hs @@ -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 diff --git a/src/Prosidy/Compile/Error.hs b/src/Prosidy/Compile/Error.hs --- a/src/Prosidy/Compile/Error.hs +++ b/src/Prosidy/Compile/Error.hs @@ -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) diff --git a/src/Prosidy/Compile/FromSetting.hs b/src/Prosidy/Compile/FromSetting.hs new file mode 100644 --- /dev/null +++ b/src/Prosidy/Compile/FromSetting.hs @@ -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)) diff --git a/src/Prosidy/Compile/Match.hs b/src/Prosidy/Compile/Match.hs --- a/src/Prosidy/Compile/Match.hs +++ b/src/Prosidy/Compile/Match.hs @@ -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 diff --git a/src/Prosidy/Compile/Run.hs b/src/Prosidy/Compile/Run.hs --- a/src/Prosidy/Compile/Run.hs +++ b/src/Prosidy/Compile/Run.hs @@ -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 diff --git a/src/Prosidy/Compile/Strict.hs b/src/Prosidy/Compile/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Prosidy/Compile/Strict.hs @@ -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 }