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.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 + +------------------------------------------------------------------------------- diff --git a/src/Data/Either/Valid.hs b/src/Data/Either/Valid.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either/Valid.hs @@ -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 #-} diff --git a/src/Data/Void/HKT.hs b/src/Data/Void/HKT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Void/HKT.hs @@ -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 diff --git a/src/Prosidy/Compile.hs b/src/Prosidy/Compile.hs --- a/src/Prosidy/Compile.hs +++ b/src/Prosidy/Compile.hs @@ -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 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 @@ -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 diff --git a/src/Prosidy/Compile/Core/Interpret.hs b/src/Prosidy/Compile/Core/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Prosidy/Compile/Core/Interpret.hs @@ -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 diff --git a/src/Prosidy/Compile/Core/Rules.hs b/src/Prosidy/Compile/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Prosidy/Compile/Core/Rules.hs @@ -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 diff --git a/src/Prosidy/Compile/DSL.hs b/src/Prosidy/Compile/DSL.hs new file mode 100644 --- /dev/null +++ b/src/Prosidy/Compile/DSL.hs @@ -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 diff --git a/src/Prosidy/Compile/Error.hs b/src/Prosidy/Compile/Error.hs deleted file mode 100644 --- a/src/Prosidy/Compile/Error.hs +++ /dev/null @@ -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 diff --git a/src/Prosidy/Compile/FromSetting.hs b/src/Prosidy/Compile/FromSetting.hs deleted file mode 100644 --- a/src/Prosidy/Compile/FromSetting.hs +++ /dev/null @@ -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)) diff --git a/src/Prosidy/Compile/Match.hs b/src/Prosidy/Compile/Match.hs deleted file mode 100644 --- a/src/Prosidy/Compile/Match.hs +++ /dev/null @@ -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 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 @@ -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 diff --git a/src/Prosidy/Compile/Strict.hs b/src/Prosidy/Compile/Strict.hs deleted file mode 100644 --- a/src/Prosidy/Compile/Strict.hs +++ /dev/null @@ -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 }