Browse Source

Add strict metadata & parsing settings (#1)

Add strict metadata & parsing settings

Co-authored-by: Alex Feldman-Crough <alex@fldcr.com>
Reviewed-on: #1
master
James Alexander Feldman-Crough 10 months ago
parent
commit
0e148fbcb8
10 changed files with 383 additions and 88 deletions
  1. +7
    -0
      CHANGELOG
  2. +1
    -1
      README.pro
  3. +4
    -2
      prosidyc.cabal
  4. +31
    -6
      src/Prosidy/Compile.hs
  5. +11
    -16
      src/Prosidy/Compile/Core.hs
  6. +69
    -24
      src/Prosidy/Compile/Error.hs
  7. +82
    -0
      src/Prosidy/Compile/FromSetting.hs
  8. +50
    -18
      src/Prosidy/Compile/Match.hs
  9. +33
    -21
      src/Prosidy/Compile/Run.hs
  10. +95
    -0
      src/Prosidy/Compile/Strict.hs

+ 7
- 0
CHANGELOG View File

@ -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
- 1
README.pro View File

@ -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.


+ 4
- 2
prosidyc.cabal View File

@ -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 @@ tested-with:
, 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 @@ library
Prosidy.Compile
, Prosidy.Compile.Core
, Prosidy.Compile.Error
, Prosidy.Compile.FromSetting
, Prosidy.Compile.Match
, Prosidy.Compile.Strict
other-modules:
Prosidy.Compile.Run


+ 31
- 6
src/Prosidy/Compile.hs View File

@ -5,15 +5,19 @@ Copyright : ©2020 James Alexander Feldman-Crough
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 @@ module Prosidy.Compile
, 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.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 )
@ -49,7 +60,12 @@ getContent = rule . GetContent
-- | 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 @@ self = rule $ GetSelf id
-- 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

+ 11
- 16
src/Prosidy/Compile/Core.hs View File

@ -42,7 +42,6 @@ import Prosidy ( Key
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 @@ 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
-- * @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 @@ type Rule input error = RuleT input error Identity
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 @@ data RuleF input error context output where
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 @@ instance CanMatch Prosidy.Inline where
-- 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


+ 69
- 24
src/Prosidy/Compile/Error.hs View File

@ -5,27 +5,33 @@ 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
, MonadErrors
, ApError(..)
, ApErrors
, singleError
, customError
, throwError1
, liftError1
, allErrors
, attachLocation
, MonadError(..)
, groupErrors
)
where
@ -44,9 +50,6 @@ import Prosidy.Optics.Source ( HasLocation(..)
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 @@ import Data.List.NonEmpty ( NonEmpty(..)
, 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 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
-- 'MonadErrors' instance.
-- | 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 @@ data Error a =
| 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 @@ data Error a =
-- 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,13 +141,27 @@ instance (Typeable a, Exception a) => Exception (Error a) where
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 "
@ -150,9 +187,17 @@ type Error' = Error Void
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 @@ customError = singleError . Custom
{-# 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)


+ 82
- 0
src/Prosidy/Compile/FromSetting.hs View File

@ -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))

+ 50
- 18
src/Prosidy/Compile/Match.hs View File

@ -14,17 +14,25 @@ module Prosidy.Compile.Match
-- ** 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 @@ newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r)
--
-- @
-- 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 @@ break = put . BreakP
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 @@ 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

+ 33
- 21
src/Prosidy/Compile/Run.hs View File

@ -5,18 +5,17 @@ Copyright : ©2020 James Alexander Feldman-Crough
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 rule = runIdentity . runM rule
-- | 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 @@ runM rule = (\(Run x) -> x) . runRun rule
-------------------------------------------------------------------------------
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

+ 95
- 0
src/Prosidy/Compile/Strict.hs View File

@ -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 }

Loading…
Cancel
Save