Fuck it, just manually define Wow, 8.6 hates this More fancy deriving because 8.6 is awful That didn't work either; manually define instances Use newtype deriving instead of Via for GHC 8.6 Oops instances Pretty printing, hoisting rules Formatting Docs docs docs Major refactor Co-authored-by: Alex Feldman-Crough <alex@fldcr.com> Reviewed-on: #2master
@ -0,0 +1,82 @@ | |||
{-| | |||
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 | |||
-- | Like 'Either', but 'Applicative' and 'Alternative' instances require | |||
-- the @e@ type parameter to admit a 'Monoid' instances. | |||
import Data.Bifunctor (Bifunctor(..)) | |||
import Control.Applicative (Alternative(..)) | |||
-- | Like the 'Either' type, but its instances accumulates its errors. As such, | |||
-- there is no 'Monad' instance for 'Valid'. | |||
-- | |||
-- The 'Invalid' constructor takes precedence over 'Valid' when used with | |||
-- classes that combine two values. | |||
-- | |||
-- Note: There are a /lot/ of packages that implement this data type, but | |||
-- finding a well-maintained one with minimal dependencies proved difficult. | |||
data Valid e a = | |||
Invalid !e | |||
| Valid !a | |||
deriving (Eq, Show, Ord) | |||
instance (Semigroup e, Semigroup a) => Semigroup (Valid e a) where | |||
Valid lhs <> Valid rhs = Valid (lhs <> rhs) | |||
Invalid lhs <> Invalid rhs = Invalid (lhs <> rhs) | |||
lhs@Invalid{} <> _ = lhs | |||
_ <> rhs = rhs | |||
instance (Semigroup e, Monoid a) => Monoid (Valid e a) where | |||
mempty = Valid mempty | |||
instance Bifunctor Valid where | |||
bimap f g = valid (Invalid . f) (Valid . g) | |||
{-# INLINABLE bimap #-} | |||
instance Functor (Valid e) where | |||
fmap = second | |||
{-# INLINE fmap #-} | |||
instance Semigroup e => Applicative (Valid e) where | |||
pure = Valid | |||
Valid fn <*> Valid x = Valid (fn x) | |||
Invalid lhs <*> Invalid rhs = Invalid (lhs <> rhs) | |||
Invalid lhs <*> _ = Invalid lhs | |||
_ <*> Invalid rhs = Invalid rhs | |||
instance Monoid e => Alternative (Valid e) where | |||
empty = Invalid mempty | |||
lhs@Valid{} <|> _ = lhs | |||
Invalid lhs <|> Invalid rhs = Invalid (lhs <> rhs) | |||
Invalid{} <|> rhs = rhs | |||
-- | Convert an 'Either' value to 'Valid'. | |||
fromEither :: Either e a -> Valid e a | |||
fromEither = either Invalid Valid | |||
{-# INLINE fromEither #-} | |||
-- | Convert a 'Valid' value to 'Either'. | |||
toEither :: Valid e a -> Either e a | |||
toEither = valid Left Right | |||
{-# INLINE toEither #-} | |||
-- | Consume a 'Valid' by handling errors and valid values. | |||
valid :: (e -> r) -> (a -> r) -> Valid e a -> r | |||
valid l r = \case | |||
Invalid e -> l e | |||
Valid a -> r a | |||
{-# INLINE valid #-} |
@ -0,0 +1,89 @@ | |||
{-| | |||
Module : Data.Void.HKT | |||
Description : A poly-kinded uninhabited type. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# OPTIONS_GHC -Wno-unused-binds #-} | |||
{-# LANGUAGE EmptyCase #-} | |||
{-# LANGUAGE LambdaCase #-} | |||
{-# LANGUAGE TypeFamilies #-} | |||
{-# LANGUAGE PolyKinds #-} | |||
module Data.Void.HKT (Void, Uninhabited(..)) where | |||
import Data.Profunctor ( Profunctor(..) | |||
, Strong(..) | |||
, Choice(..) | |||
) | |||
import Data.Bifunctor ( Bifunctor(..) ) | |||
-- | A poly-kinded, uninhabited type family. | |||
data family Void :: k | |||
-- | The uninhabited type taking no arguments. | |||
data instance Void | |||
-- | The uninhabited type taking one argument. | |||
newtype instance Void (a :: ka) = Void1 Void | |||
-- | The uninhabited type taking two arguments. | |||
newtype instance Void (a :: ka) (b :: kb) = Void2 Void | |||
-- | The uninhabited type taking three arguments. | |||
newtype instance Void (a :: ka) (b :: kb) (c :: kc) = Void3 Void | |||
-- | Defines uninhabited types. | |||
class Uninhabited a where | |||
-- | If @a@ is an uninhabited type, we will never receive a value of type | |||
-- @a@ and thus we can return a value of any type. | |||
absurd :: a -> b | |||
instance Uninhabited Void where | |||
absurd = \case {} | |||
instance Uninhabited (Void a) where | |||
absurd = \case {} | |||
instance Uninhabited (Void a b) where | |||
absurd = \case {} | |||
instance Uninhabited (Void a b c) where | |||
absurd = \case {} | |||
instance Functor Void where | |||
fmap = const absurd | |||
instance Functor (Void a) where | |||
fmap = const absurd | |||
instance Functor (Void a b) where | |||
fmap = const absurd | |||
instance Bifunctor Void where | |||
bimap = const (const absurd) | |||
instance Bifunctor (Void a) where | |||
bimap = const (const absurd) | |||
instance Profunctor Void where | |||
dimap = const (const absurd) | |||
instance Profunctor (Void a) where | |||
dimap = const (const absurd) | |||
instance Strong Void where | |||
first' = absurd | |||
second' = absurd | |||
instance Strong (Void a) where | |||
first' = absurd | |||
second' = absurd | |||
instance Choice Void where | |||
left' = absurd | |||
right' = absurd | |||
instance Choice (Void a) where | |||
left' = absurd | |||
right' = absurd |
@ -1,110 +1,12 @@ | |||
{-| | |||
Module : Prosidy.Compile | |||
Description : Compile Prosidy documents into other shapes | |||
Description : Reexport module. You probable want to import this. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE ApplicativeDo #-} | |||
{-# LANGUAGE DefaultSignatures #-} | |||
{-# LANGUAGE DerivingVia #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE LambdaCase #-} | |||
{-# LANGUAGE OverloadedStrings #-} | |||
{-# LANGUAGE TypeFamilies #-} | |||
{-# LANGUAGE TypeApplications #-} | |||
{-# LANGUAGE ScopedTypeVariables #-} | |||
{-# LANGUAGE UndecidableInstances #-} | |||
module Prosidy.Compile | |||
( escapeHatch | |||
, getContent | |||
, matchContent | |||
, optParse | |||
, prop | |||
, reqParse | |||
, traversing | |||
, self | |||
, strict | |||
, RuleT | |||
, Rule | |||
, CanMatch | |||
, Error(..) | |||
, ErrorSet | |||
, Error' | |||
, ErrorSet' | |||
, FromSetting(..) | |||
, req | |||
, opt | |||
, module Prosidy.Compile.Match | |||
, module Prosidy.Compile.Run | |||
) | |||
where | |||
module Prosidy.Compile (module X) 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 | |||
-- | Retrieve an required setting, parsing using its 'FromSetting' instance. | |||
req :: (FromSetting a, P.HasMetadata i) => P.Key -> RuleT i e f a | |||
req key = reqParse key fromSetting | |||
import Prosidy.Compile.Core as X | |||
import Prosidy.Compile.DSL as X | |||
import Prosidy.Compile.Run as X |
@ -1,286 +1,12 @@ | |||
{-| | |||
Module : Prosidy.Compile.Core | |||
Description : Primitive type definitions and functions. | |||
Module : Prosidy.Compile.Core.Rule | |||
Description : Basic contextual compilation rules | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DeriveFunctor #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE TypeFamilies #-} | |||
{-# LANGUAGE KindSignatures #-} | |||
{-# LANGUAGE DerivingVia #-} | |||
{-# LANGUAGE QuantifiedConstraints #-} | |||
{-# LANGUAGE GeneralisedNewtypeDeriving #-} | |||
{-# LANGUAGE GADTs #-} | |||
{-# LANGUAGE RankNTypes #-} | |||
{-# LANGUAGE LambdaCase #-} | |||
module Prosidy.Compile.Core | |||
( RuleF(..) | |||
, RuleT | |||
, Rule | |||
, CanMatch(evalPattern, noMatchError) | |||
, Pattern(..) | |||
, Interpret | |||
, BlockRegion | |||
, InlineRegion | |||
, LiteralRegion | |||
, interpretWith | |||
, evalPatterns | |||
, rule | |||
) | |||
where | |||
module Prosidy.Compile.Core (module X) 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) | |||
-- | A 'Prosidy.Types.LiteralTag' with the tag name removed. | |||
type LiteralRegion = Prosidy.Region Text | |||
import Prosidy.Compile.Core.Interpret | |||
as X | |||
import Prosidy.Compile.Core.Rules as X |
@ -0,0 +1,68 @@ | |||
{-# LANGUAGE TypeApplications #-} | |||
{-# LANGUAGE ScopedTypeVariables #-} | |||
{-| | |||
Module : Prosidy.Compile.Core.Interpret | |||
Description : Internal module declaring the 'Context' and 'Interpret' classes. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DefaultSignatures #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE QuantifiedConstraints #-} | |||
{-# LANGUAGE TypeFamilies #-} | |||
module Prosidy.Compile.Core.Interpret | |||
( Context(..) | |||
, Interpret(..) | |||
, interpret | |||
) | |||
where | |||
import Control.Applicative ( Alternative ) | |||
import Prosidy.Compile.Core.Rules ( RuleFor | |||
, Rules | |||
, Rule(..) | |||
, runRules | |||
) | |||
import Data.Void.HKT ( Void | |||
, absurd | |||
) | |||
-- | A base class for interpreters of 'Rules'. | |||
class (forall i. Alternative (t i)) => Context t where | |||
-- | Access the current focus of an interpreter. This function is similar | |||
-- in purpose to 'Control.Monad.Trans.Reader.ask'. | |||
runSelf :: t i i | |||
-- | A type for expressions that can be lifted by the interpreter. | |||
-- | |||
-- This type defaults to an uninhabited type. Only override this type | |||
-- if you intend on overriding 'liftRule', as well. | |||
type Local t :: * -> * | |||
-- | Lift an expression of type 'Local' into the interpreter. | |||
-- | |||
-- By default, 'Local' is left as an uninhabted type and escaping via | |||
-- 'liftRule' can never happen. Override both 'Local' and 'liftRule' to | |||
-- permit arbitrary computation. | |||
liftRule :: Local t a -> t i a | |||
type Local t = Void t | |||
default liftRule :: Local t a ~ Void t a => Local t a -> t i a | |||
liftRule = absurd | |||
-- | Instructs a 'Context' how to interpret a single rule. | |||
class Context t => Interpret t i where | |||
-- | Evaluate a single rule into the context. | |||
runRule :: RuleFor i (Local t) a -> t i a | |||
default runRule :: (RuleFor i ~ Void i) => RuleFor i (Local t) a -> t i a | |||
runRule = absurd | |||
-- | Evaluate 'Rules' into a contextual interpreter. | |||
interpret :: forall t i a. Interpret t i => Rules i (Local t) a -> t i a | |||
interpret = runRules $ \x -> case x of | |||
RuleFor r -> runRule r | |||
Escape f -> liftRule f | |||
Self s -> s <$> runSelf |
@ -0,0 +1,291 @@ | |||
{-| | |||
Module : Prosidy.Compile.Core.Rules | |||
Description : Internal module declaring 'Rules' types and functions. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DeriveFunctor #-} | |||
{-# LANGUAGE DerivingStrategies #-} | |||
{-# LANGUAGE EmptyCase #-} | |||
{-# LANGUAGE ExistentialQuantification #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |||
{-# LANGUAGE KindSignatures #-} | |||
{-# LANGUAGE LambdaCase #-} | |||
{-# LANGUAGE PolyKinds #-} | |||
{-# LANGUAGE RankNTypes #-} | |||
{-# LANGUAGE StrictData #-} | |||
{-# LANGUAGE TypeFamilyDependencies #-} | |||
{-# LANGUAGE UndecidableInstances #-} | |||
module Prosidy.Compile.Core.Rules | |||
( Rules | |||
, Rule(..) | |||
, rule | |||
, local | |||
, self | |||
, runRules | |||
, mapRules | |||
, hoist | |||
, HoistRuleFor | |||
-- * Context-aware ADT rules. | |||
, RuleFor | |||
, BlockRule(..) | |||
, DocumentRule(..) | |||
, FragmentRule(..) | |||
, InlineRule(..) | |||
, MetadataRule(..) | |||
, ParagraphRule(..) | |||
, RegionRule(..) | |||
, SeriesNERule(..) | |||
, SeriesRule(..) | |||
, TagRule(..) | |||
-- * Reëxports | |||
, Alternative(..) | |||
) | |||
where | |||
import Prosidy.Types | |||
import Prosidy.Source ( Location ) | |||
import Data.Void.HKT ( Void ) | |||
import Data.Text ( Text ) | |||
import Control.Applicative ( Alternative(..) ) | |||
import qualified Control.Alternative.Free.Final | |||
as Alt | |||
------------------------------------------------------------------------------- | |||
-- | A container for building up compilation rules. | |||
-- | |||
-- * The type parameter @t@ specifies the /input type/ of these rules. It will | |||
-- almost always be a Prosidy node type, such as 'Document' or 'Tag'. | |||
-- | |||
-- * The type parameter @f@ is a contextual functor for implementing custom | |||
-- extensions on top of 'Rules'. | |||
newtype Rules t f a = Rules | |||
{ _runRules :: Alt.Alt (Rule t f) a | |||
} | |||
deriving newtype (Functor, Applicative, Alternative, Semigroup, Monoid) | |||
-- | Lift a single rule into the 'Rules' functor. | |||
rule :: RuleFor t f a -> Rules t f a | |||
rule = Rules . Alt.liftAlt . RuleFor | |||
-- | Lift a contextual item into 'Rules'. | |||
local :: Functor f => f a -> Rules t f a | |||
local = Rules . Alt.liftAlt . Escape | |||
-- | Get the currently focused node as a value. | |||
self :: Rules t f t | |||
self = Rules . Alt.liftAlt $ Self id | |||
-- | Given an interpreter which can convert 'Rule's into the functor @g@, | |||
-- convert 'Rules' into the functor @g@. | |||
runRules | |||
:: Alternative g => (forall b . Rule t f b -> g b) -> Rules t f a -> g a | |||
runRules interpret = Alt.runAlt interpret . _runRules | |||
-- | Map over the contextual functor @f@ in 'Rules'. | |||
hoist :: HoistRuleFor t => (forall b. f b -> g b) -> Rules t f a -> Rules t g a | |||
hoist fToG = Rules . Alt.hoistAlt (hoistRule fToG) . _runRules | |||
-- | Map over 'Rules'. | |||
mapRules | |||
:: forall a a' t t' f | |||
. (Functor f, Functor (RuleFor t' f)) | |||
=> (forall x . RuleFor t f x -> RuleFor t' f x) | |||
-- ^ Maps over rules themselves, keeping the context and output types the | |||
-- same. | |||
-> (t' -> t) | |||
-- ^ Maps over the input to rules. | |||
-> (a -> a') | |||
-- ^ Maps over the output of rules. | |||
-> Rules t f a | |||
-> Rules t' f a' | |||
mapRules f g h (Rules alt) = Rules $ h <$> Alt.hoistAlt (mapRule f g id) alt | |||
------------------------------------------------------------------------------- | |||
-- | An individual 'Rule' in isolation. | |||
data Rule t f a = | |||
RuleFor (RuleFor t f a) -- ^ A rule specific to the input type @t@ | |||
| Escape (f a) -- ^ An escape hatch, allowing arbitrary computation | |||
| Self (t -> a) -- ^ A rule which converts the input type to an output. | |||
instance (Functor f, Functor (RuleFor t f)) => Functor (Rule t f) where | |||
fmap fn x = case x of | |||
RuleFor rule -> RuleFor $ fn <$> rule | |||
Escape rule -> Escape $ fn <$> rule | |||
Self self -> Self $ fn <$> self | |||
hoistRule :: HoistRuleFor t => (forall b. f b -> g b) -> Rule t f a -> Rule t g a | |||
hoistRule f (RuleFor rf) = RuleFor (hoistRuleFor f rf) | |||
hoistRule f (Escape fa) = Escape (f fa) | |||
hoistRule _ (Self fn) = Self fn | |||
mapRule | |||
:: (Functor f, Functor (RuleFor t' f)) | |||
=> (forall x . RuleFor t f x -> RuleFor t' f x) | |||
-> (t' -> t) | |||
-> (a -> a') | |||
-> Rule t f a | |||
-> Rule t' f a' | |||
mapRule f _ h (RuleFor r ) = RuleFor . fmap h . f $ r | |||
mapRule _ _ h (Escape es ) = Escape $ h <$> es | |||
mapRule _ g h (Self self) = Self $ h . self . g | |||
------------------------------------------------------------------------------- | |||
-- | Defines a relationship between input types and rules specific to those | |||
-- input types. | |||
type family RuleFor t = (rule :: (* -> *) -> * -> *) | rule -> t where | |||
RuleFor Block = BlockRule | |||
RuleFor Document = DocumentRule | |||
RuleFor Fragment = FragmentRule | |||
RuleFor Inline = InlineRule | |||
RuleFor Metadata = MetadataRule | |||
RuleFor Paragraph = ParagraphRule | |||
RuleFor (Region a) = RegionRule a | |||
RuleFor (Series a) = SeriesRule a | |||
RuleFor (SeriesNE a) = SeriesNERule a | |||
RuleFor (Tag a) = TagRule a | |||
RuleFor a = Void a | |||
-- | A class defining how to map over the contextual parameter @f@ in a rule for | |||
-- the type @t@. | |||
class HoistRuleFor t where | |||
hoistRuleFor :: (forall b. f b -> g b) -> RuleFor t f a -> RuleFor t g a | |||
------------------------------------------------------------------------------- | |||
-- | Rules for matching specific types of 'Block' nodes. | |||
data BlockRule f a = | |||
BlockRuleBlockTag (Rules BlockTag f a) | |||
| BlockRuleLiteralTag (Rules LiteralTag f a) | |||
| BlockRuleParagraph (Rules Paragraph f a) | |||
deriving stock Functor | |||
instance HoistRuleFor Block where | |||
hoistRuleFor f = \case | |||
BlockRuleBlockTag rules -> BlockRuleBlockTag $ hoist f rules | |||
BlockRuleLiteralTag rules -> BlockRuleLiteralTag $ hoist f rules | |||
BlockRuleParagraph rules -> BlockRuleParagraph $ hoist f rules | |||
------------------------------------------------------------------------------- | |||
-- | Rules applying to 'Document's. | |||
newtype DocumentRule f a = | |||
DocumentRule (RegionRule (Series Block) f a) | |||
deriving newtype Functor | |||
instance HoistRuleFor Document where | |||
hoistRuleFor f = \case | |||
DocumentRule r -> DocumentRule $ hoistRuleFor f r | |||
------------------------------------------------------------------------------- | |||
-- | Rules applying to 'Fragment's (i.e. plain text). | |||
data FragmentRule f a = | |||
FragmentRuleLocation (Maybe Location -> a) | |||
| FragmentRuleText (Text -> a) | |||
deriving stock Functor | |||
instance HoistRuleFor Fragment where | |||
hoistRuleFor _ = \case | |||
FragmentRuleLocation fn -> FragmentRuleLocation fn | |||
FragmentRuleText fn -> FragmentRuleText fn | |||
------------------------------------------------------------------------------- | |||
-- | Rules for matching specific types of 'Inline' nodes. | |||
data InlineRule f a = | |||
InlineRuleBreak a | |||
| InlineRuleFragment (Rules Fragment f a) | |||
| InlineRuleInlineTag (Rules InlineTag f a) | |||
deriving stock Functor | |||
instance HoistRuleFor Inline where | |||
hoistRuleFor f = \case | |||
InlineRuleBreak a -> InlineRuleBreak a | |||
InlineRuleFragment rules -> InlineRuleFragment $ hoist f rules | |||
InlineRuleInlineTag rules -> InlineRuleInlineTag $ hoist f rules | |||
------------------------------------------------------------------------------- | |||
-- | Rules for operating on properties and settings. | |||
data MetadataRule f a = | |||
MetadataRuleProperty (Bool -> a) Key | |||
| MetadataRuleSetting (Text -> Either String a) (Maybe a) Key | |||
| MetadataRuleAllowUnknown a | |||
deriving stock Functor | |||
instance HoistRuleFor Metadata where | |||
hoistRuleFor _ = \case | |||
MetadataRuleProperty fn key -> MetadataRuleProperty fn key | |||
MetadataRuleSetting fn def key -> MetadataRuleSetting fn def key | |||
MetadataRuleAllowUnknown a -> MetadataRuleAllowUnknown a | |||
------------------------------------------------------------------------------- | |||
-- | Rules for accessing paragraphs. | |||
data ParagraphRule f a = | |||
ParagraphRuleContent (Rules (SeriesNE Inline) f a) | |||
| ParagraphRuleLocation (Maybe Location -> a) | |||
deriving stock Functor | |||
instance HoistRuleFor Paragraph where | |||
hoistRuleFor f = \case | |||
ParagraphRuleContent rules -> ParagraphRuleContent $ hoist f rules | |||
ParagraphRuleLocation fn -> ParagraphRuleLocation fn | |||
------------------------------------------------------------------------------- | |||
-- | Rules for operating on a 'Region'. | |||
data RegionRule t f a = | |||
RegionRuleLocation (Maybe Location -> a) | |||
| RegionRuleMetadata (MetadataRule f a) | |||
| RegionRuleContent (Rules t f a) | |||
deriving stock Functor | |||
instance HoistRuleFor t => HoistRuleFor (Region t) where | |||
hoistRuleFor f = \case | |||
RegionRuleLocation fn -> RegionRuleLocation fn | |||
RegionRuleMetadata rule -> RegionRuleMetadata $ hoistRuleFor f rule | |||
RegionRuleContent rules -> RegionRuleContent $ hoist f rules | |||
------------------------------------------------------------------------------- | |||
-- | Operates sequentially against a collection of nodes. | |||
data SeriesRule t f a = | |||
SeriesRuleNext (SeriesNERule t f a) | |||
| SeriesRuleEmpty a | |||
instance Functor (SeriesRule t f) where | |||
fmap fn (SeriesRuleNext rule) = SeriesRuleNext (fmap fn rule) | |||
fmap fn (SeriesRuleEmpty x ) = SeriesRuleEmpty (fn x) | |||
instance HoistRuleFor t => HoistRuleFor (Series t) where | |||
hoistRuleFor f = \case | |||
SeriesRuleNext rule -> SeriesRuleNext $ hoistRuleFor f rule | |||
SeriesRuleEmpty a -> SeriesRuleEmpty a | |||
------------------------------------------------------------------------------- | |||
-- | Operates sequentially against a non-empty collection of nodes. | |||
data SeriesNERule t f a = | |||
forall b c. SeriesNERule (b -> c -> a) (Rules t f b) (Rules (Series t) f c) | |||
instance Functor (SeriesNERule t f) where | |||
fmap fn (SeriesNERule k rule next) = SeriesNERule (fmap fn . k) rule next | |||
instance HoistRuleFor t => HoistRuleFor (SeriesNE t) where | |||
hoistRuleFor f = \case | |||
SeriesNERule k r1 rs -> SeriesNERule k (hoist f r1) (hoist f rs) | |||
------------------------------------------------------------------------------- | |||
-- | Rules for operating on 'Tag's. | |||
data TagRule t f a = | |||
TagRuleKey Key a | |||
| TagRuleRegion (RegionRule t f a) | |||
deriving stock Functor | |||
instance HoistRuleFor t => HoistRuleFor (Tag t) where | |||
hoistRuleFor f = \case | |||
TagRuleKey k a -> TagRuleKey k a | |||
TagRuleRegion rule -> TagRuleRegion $ hoistRuleFor f rule | |||
------------------------------------------------------------------------------- | |||
instance HoistRuleFor Text where | |||
hoistRuleFor _ = \case |
@ -0,0 +1,271 @@ | |||
{-| | |||
Module : Prosidy.Compile.DSL | |||
Description : An EDSL for declaring 'Prosidy.Compile.Core.Rules'. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DefaultSignatures #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE ScopedTypeVariables #-} | |||
{-# LANGUAGE TypeApplications #-} | |||
{-# LANGUAGE TypeSynonymInstances #-} | |||
{-# LANGUAGE PatternSynonyms #-} | |||
module Prosidy.Compile.DSL | |||
( content | |||
-- * Series rules | |||
, (&>) | |||
, (&>>) | |||
, folded | |||
, folded1 | |||
, collect | |||
, end | |||
, endWith | |||
-- * Metadata rules | |||
, prop | |||
, req | |||
, opt | |||
, lax | |||
-- * Matchers | |||
, Match | |||
, match | |||
, blockTag | |||
, inlineTag | |||
, literalTag | |||
, paragraph | |||
, text | |||
, breakWith | |||
-- * Get wild with actions | |||
, local | |||
, self | |||
, hoist | |||
-- * Convenience classes | |||
, FromSetting(..) | |||
, RegionLike | |||
) | |||
where | |||
import qualified Prosidy | |||
import Prosidy.Types.Series ( pattern Empty | |||
, pattern (:<:) | |||
, pattern (:<<:) | |||
) | |||
import Prosidy.Compile.Core | |||
import Data.Monoid ( Alt(..) ) | |||
import Text.Read ( readMaybe ) | |||
import Type.Reflection ( Typeable | |||
, typeRep | |||
) | |||
import Data.Text ( Text ) | |||
import qualified Data.Text as Text | |||
import qualified Data.Text.Lazy as Text.Lazy | |||
import Numeric.Natural ( Natural ) | |||
infixr 3 &> | |||
infixr 1 &>> | |||
------------------------------------------------------------------------------- | |||
-- | Access the inner content of the 'RegionLike' value @t@. | |||
content :: RegionLike t => Rules (Prosidy.Content t) f a -> Rules t f a | |||
content = rule . liftRegionRule . RegionRuleContent | |||
------------------------------------------------------------------------------- | |||
-- | Given a 'Prosidy.Series', perform the rule on the left hand side on the | |||
-- first element of the 'Prosidy.Series', and the rule on the right hand side | |||
-- on all items after the first. | |||
-- | |||
-- This can be used to define rules which must be evaluated sequentially. | |||
(&>) | |||
:: Rules t f a | |||
-> Rules (Prosidy.Series t) f (Prosidy.Series a) | |||
-> Rules (Prosidy.Series t) f (Prosidy.Series a) | |||
r &> rs = rule . SeriesRuleNext $ SeriesNERule (:<:) r rs | |||
-- | Like '(&>)', but returns a combined rule which operates on a non-empty | |||
-- series ('Prosidy.SeriesNE'). | |||
(&>>) | |||
:: Rules t f a | |||
-> Rules (Prosidy.Series t) f (Prosidy.Series a) | |||
-> Rules (Prosidy.SeriesNE t) f (Prosidy.SeriesNE a) | |||
r &>> rs = rule $ SeriesNERule (:<<:) r rs | |||
-- | Match the end of a 'Prosidy.Series'. | |||
end :: Rules (Prosidy.Series t) f (Prosidy.Series a) | |||
end = endWith Empty | |||
-- | Match the end of a 'Prosidy.Series', returning the provided value. | |||
endWith :: a -> Rules (Prosidy.Series t) f a | |||
endWith = rule . SeriesRuleEmpty | |||
-- | Lift a rule to collect many of that rule in series | |||
collect :: Rules t f a -> Rules (Prosidy.Series t) f (Prosidy.Series a) | |||
collect rules = go | |||
where | |||
go = (rules &> go) <|> end | |||
-- | Lift a rule to operate on a 'Prosidy.Series' by folding the results of | |||
-- evaluation against each element into a single result. | |||
folded :: Monoid a => Rules t f a -> Rules (Prosidy.Series t) f a | |||
folded r = go | |||
where | |||
go = rule (SeriesRuleNext $ SeriesNERule (<>) r go) | |||
<|> rule (SeriesRuleEmpty mempty) | |||
-- | Like 'folded', but operates on a non-empty series. | |||
folded1 :: Monoid a => Rules t f a -> Rules (Prosidy.SeriesNE t) f a | |||
folded1 r = rule $ SeriesNERule (<>) r (folded r) | |||
------------------------------------------------------------------------------- | |||
-- | A class for recursive nodes in a document. | |||
class Prosidy.HasContent t => RegionLike t where | |||
liftRegionRule :: RegionRule (Prosidy.Content t) f a -> RuleFor t f a | |||
instance RegionLike Prosidy.Document where | |||
liftRegionRule = DocumentRule | |||
instance RegionLike (Prosidy.Tag t) where | |||
liftRegionRule = TagRuleRegion | |||
instance RegionLike (Prosidy.Region t) where | |||
liftRegionRule = id | |||
-- | Check if a 'Prosidy.Metadata' property is set on a node. | |||
prop :: RegionLike t => Prosidy.Key -> Rules t f Bool | |||
prop = rule . liftRegionRule . RegionRuleMetadata . MetadataRuleProperty id | |||
-- | Fetch a /required/ 'Prosidy.Metadata' value from a node, parsing it using | |||
-- the provided function. | |||
reqWith | |||
:: forall a t f. RegionLike t => (Text -> Either String a) -> Prosidy.Key -> Rules t f a | |||
reqWith parse = | |||
rule | |||
. liftRegionRule | |||
. RegionRuleMetadata | |||
. MetadataRuleSetting parse Nothing | |||
-- | Fetch a /required/ 'Prosidy.Metadata' setting from a node. | |||
req :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f a | |||
req = reqWith parseSetting | |||
-- | Fetch an /optional/ 'Prosidy.Metadata' value from a node, parsing it using | |||
-- the provided function. | |||
optWith | |||
:: forall a t f. RegionLike t | |||
=> (Text -> Either String a) | |||
-> Prosidy.Key | |||
-> Rules t f (Maybe a) | |||
optWith parse = | |||
rule . liftRegionRule . RegionRuleMetadata . MetadataRuleSetting | |||
(fmap Just . parse) | |||
(Just Nothing) | |||
-- | Fetch an /optional/ 'Prosidy.Metadata' setting from a node. | |||
opt :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f (Maybe a) | |||
opt = optWith parseSetting | |||
-- | Allow unknown properties and settings in this region. | |||
lax :: RegionLike t => Rules t f () | |||
lax = rule . liftRegionRule . RegionRuleMetadata $ MetadataRuleAllowUnknown () | |||
------------------------------------------------------------------------------- | |||
-- | A class for values which can be parsed from 'Text'. | |||
class FromSetting a where | |||
parseSetting :: Text -> Either String a | |||
default parseSetting :: (Typeable a, Read a) => Text -> Either String a | |||
parseSetting raw = case readMaybe (Text.unpack raw) of | |||
Just ok -> Right ok | |||
Nothing -> Left $ "Failed to parse " <> show raw <> " as type " <> show (typeRep @a) | |||
instance FromSetting Double | |||
instance FromSetting Float | |||
instance FromSetting Int | |||
instance FromSetting Integer | |||
instance FromSetting Natural | |||
instance FromSetting Word | |||
instance FromSetting String where | |||
parseSetting = Right . Text.unpack | |||
instance FromSetting Text where | |||
parseSetting = Right | |||
{-# INLINE parseSetting #-} | |||
instance FromSetting Text.Lazy.Text where | |||
parseSetting = Right . Text.Lazy.fromStrict | |||
{-# INLINE parseSetting #-} | |||
------------------------------------------------------------------------------- | |||
-- | A type used to declare alternatives in @do@ notation. | |||
type Match t f a = MatchM t f a () | |||
data MatchM t f a r = MatchM !(Alt (Rules t f) a) !r | |||
instance Semigroup r => Semigroup (MatchM t a f r) where | |||
MatchM r a <> MatchM s b = MatchM (r <> s) (a <> b) | |||
instance Monoid r => Monoid (MatchM t a f r) where | |||
mempty = MatchM mempty mempty | |||
instance Functor (MatchM t f a) where | |||
fmap fn (MatchM r x) = MatchM r (fn x) | |||
instance Applicative (MatchM t f a) where | |||
pure = MatchM mempty | |||
MatchM lhs fn <*> MatchM rhs x = MatchM (lhs <> rhs) (fn x) | |||
instance Monad (MatchM t f a) where | |||
MatchM lhs x >>= f = let MatchM rhs x' = f x in MatchM (lhs <> rhs) x' | |||
-- | Lifts a 'Match' into 'Rules' by trying each defined pattern, from top to | |||
-- bottom, until a match is found. | |||
match :: Match t f a -> Rules t f a | |||
match (MatchM (Alt r) ()) = r | |||
-- | Match a 'Prosidy.BlockTag' with the proided 'Prosidy.Key'. | |||
blockTag | |||
:: Functor f | |||
=> Prosidy.Key | |||
-> Rules Prosidy.BlockRegion f a | |||
-> Match Prosidy.Block f a | |||
blockTag key = matchRule . BlockRuleBlockTag . tagRule key | |||
-- | Match a 'Prosidy.LiteralTag' with the provided 'Prosidy.Key'. | |||
literalTag | |||
:: Functor f | |||
=> Prosidy.Key | |||
-> Rules Prosidy.LiteralRegion f a | |||
-> Match Prosidy.Block f a | |||
literalTag key = matchRule . BlockRuleLiteralTag . tagRule key | |||
-- | Match a 'Prosidy.InlineTag' with the provided 'Prosidy.Key'. | |||
inlineTag | |||
:: Functor f | |||
=> Prosidy.Key | |||
-> Rules Prosidy.InlineRegion f a | |||
-> Match Prosidy.Inline f a | |||
inlineTag key = matchRule . InlineRuleInlineTag . tagRule key | |||
-- | Match a paragraph which is not enclosed in a tag. | |||
paragraph | |||
:: Rules (Prosidy.SeriesNE Prosidy.Inline) f a -> Match Prosidy.Block f a | |||
paragraph = matchRule . BlockRuleParagraph . rule . ParagraphRuleContent | |||
-- | Match textual content, transforming it with the provided function. | |||
text :: (Text -> a) -> Match Prosidy.Inline f a | |||
text = matchRule . InlineRuleFragment . rule . FragmentRuleText | |||
-- | Replace inline breaks with the provided vlaue. | |||
breakWith :: a -> Match Prosidy.Inline f a | |||
breakWith = matchRule . InlineRuleBreak | |||
matchRule :: RuleFor t f a -> Match t f a | |||
matchRule = flip MatchM () . Alt . rule | |||
tagRule | |||
:: Functor f | |||
=> Prosidy.Key | |||
-> Rules (Prosidy.Region t) f a | |||
-> Rules (Prosidy.Tag t) f a | |||
tagRule key r = | |||
rule (TagRuleKey key ()) *> mapRules liftRegionRule Prosidy.tagToRegion id r |
@ -1,220 +0,0 @@ | |||
{-| | |||
Module : Prosidy.Compile.Error | |||
Description : Error definitions and utility functions. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DerivingVia #-} | |||
{-# LANGUAGE FunctionalDependencies #-} | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE ConstraintKinds #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE LambdaCase #-} | |||
{-# LANGUAGE DeriveAnyClass #-} | |||
{-# LANGUAGE DeriveGeneric #-} | |||
{-# LANGUAGE DefaultSignatures #-} | |||
{-# LANGUAGE DerivingStrategies #-} | |||
{-# LANGUAGE GeneralisedNewtypeDeriving #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
module Prosidy.Compile.Error | |||
( Error(..) | |||
, TagKind(..) | |||
, MetadataKind(..) | |||
, ErrorSet | |||
, Error' | |||
, ErrorSet' | |||
, IsError | |||
, ApError(..) | |||
, ApErrors | |||
, singleError | |||
, customError | |||
, liftError1 | |||
, allErrors | |||
, groupErrors | |||
) | |||
where | |||
import Lens.Micro | |||
import Control.Exception ( Exception(..) ) | |||
import Prosidy.Types.Key ( Key ) | |||
import Prosidy.Source ( Line(..) | |||
, Column(..) | |||
, Location | |||
) | |||
import Prosidy.Optics.Source ( HasLocation(..) | |||
, line | |||
, column | |||
) | |||
import Data.HashSet ( HashSet | |||
, singleton | |||
) | |||
import GHC.Generics ( Generic ) | |||
import Data.Hashable ( Hashable ) | |||
import Data.Typeable ( Typeable ) | |||
import Data.Void ( Void ) | |||
import Data.Foldable ( toList ) | |||
import Data.List.NonEmpty ( NonEmpty(..) | |||
, nonEmpty | |||
) | |||
-- | Similar to 'Control.Monad.Except.MonadError', but without the 'Monad' | |||
-- constraint, and without a method to handle errors, only a method to map over | |||
-- them. | |||
class Applicative f => ApError e f | f -> e where | |||
liftError :: e -> f a | |||
mapError :: (e -> e) -> f a -> f a | |||
-- | A synonym for 'ApError' when the underlying applicative is capable of | |||
-- accumulating errors in an 'ErrorSet'. | |||
type ApErrors e = ApError (ErrorSet e) | |||
-- | A constraint alias for errors throwable in a context admitting a | |||
-- 'ApErrors' instance. | |||
type IsError e = (Exception e, Hashable e, Eq e) | |||
-- | A non-empty set of errors. | |||
newtype ErrorSet e = | |||
ErrorSet (HashSet (Error e)) | |||
deriving stock (Show, Generic, Eq) | |||
deriving anyclass (Hashable) | |||
instance Exception e => Exception (ErrorSet e) where | |||
displayException (ErrorSet errors) = mconcat | |||
[ showString "encountered " <> shows (length errors) <> showString | |||
" error(s):\n" | |||
, showString "-----\n" | |||
, foldMap (\x -> showString (displayException x) . showChar '\n') errors | |||
] | |||
"" | |||
instance IsError e => Semigroup (ErrorSet e) where | |||
ErrorSet lhs <> ErrorSet rhs = ErrorSet $! lhs <> rhs | |||
-- | A type alias for 'ErrorSet's which never contain empty errors. | |||
type ErrorSet' = ErrorSet Void | |||
-- | Enumerates the errors thrown when | |||
data Error a = | |||
Custom a | |||
-- ^ A custom error, allowing extensibility. | |||
| ParseError Key String | |||
-- ^ Thrown when parsing a setting fails. | |||
| Required Key | |||
-- ^ Thrown when a setting was required to be set, but wasn't provided. | |||
| ExpectedTag TagKind Key | |||
-- ^ Thrown when matching against a 'Prosidy.Tag', and another node was | |||
-- found, or the input tag's 'Key' didn't match the specified key. | |||
| ExpectedParagraph | |||
-- ^ Thrown when matching against paragraph and an unexpected node was | |||
-- encountered. | |||
| ExpectedText | |||
-- ^ Thrown when matching against text and an unexpected node was | |||
-- encountered. | |||
| ExpectedBreak | |||
-- ^ Thrown when matching against an explicit break and an unexpected node | |||
-- was encountered. | |||
| EmptyMatch | |||
-- ^ Thrown when a match has no cases to check against. | |||
| UnknownMetadata (HashSet (MetadataKind, Key)) | |||
-- ^ Thrown when an unknown property or setting is encountered when | |||
-- checking that properties and settings conform to strictly known | |||
-- keys. | |||
| Group (Maybe Location) (ErrorSet a) | |||
-- ^ Used to group a set of errors thrown at the same point in a tree. | |||
deriving (Eq, Show, Generic, Hashable) | |||
instance (Typeable a, Exception a) => Exception (Error a) where | |||
displayException (Custom a ) = displayException a | |||
displayException (ParseError k msg) = mconcat | |||
[ showString "failed to parse the setting " | |||
, shows k | |||
, showString ": " | |||
, showString msg | |||
] | |||
"" | |||
displayException EmptyMatch = "Match provided with no possible cases." | |||
displayException (Required k) = "missing required setting " <> show k | |||
displayException (ExpectedTag kind k) = | |||
"expected a " <> kindstr kind <> " tag with key " <> show k | |||
where | |||
kindstr BlockKind = "block" | |||
kindstr InlineKind = "inline" | |||
kindstr LiteralKind = "literal" | |||
displayException ExpectedParagraph = "expected a paragrapgh" | |||
displayException ExpectedText = "expected plain text" | |||
displayException ExpectedBreak = "expected a break" | |||
displayException (UnknownMetadata xs) = | |||
showString "One or more invalid metadata items were encountered:" | |||
<> foldMap showItem xs | |||
$ "" | |||
where | |||
showItem (PropertyKind, key) = | |||
showChar ' ' <> shows key <> showString " (property)" | |||
showItem (SettingKind, key) = | |||
showChar ' ' <> shows key <> showString " (setting)" | |||
displayException (Group (Just loc) x) = mconcat | |||
[ showString "error(s) encountered at line " | |||
, shows (loc ^?! line . to (\(Line n) -> succ n)) | |||
, showString " column " | |||
, shows (loc ^?! column . to (\(Column n) -> succ n)) | |||
, showString ":\n" | |||
, foldMap | |||
(\exn -> showString (displayException exn) <> showChar '\n') | |||
(allErrors x) | |||
] | |||
"" | |||
displayException (Group Nothing x) = foldMap | |||
(\exn -> showString (displayException exn) <> showChar '\n') | |||
(allErrors x) | |||
"" | |||
-- | A type alias for 'Error's that never throw a custom error. | |||
type Error' = Error Void | |||
-- | A marker class for marking which type of tag 'ExpectedTag' was expecting. | |||
data TagKind = BlockKind | InlineKind | LiteralKind | |||
deriving (Show, Eq, Generic, Hashable) | |||
-- | A marker class for marking which type of metadata (settings or property) | |||
-- a key corresponds to. | |||
data MetadataKind = PropertyKind | SettingKind | |||
deriving (Show, Eq, Generic, Hashable) | |||
-- | Group errors together, attaching a location if one is available. | |||
groupErrors :: (IsError e, ApErrors e m, HasLocation l) => l -> m a -> m a | |||
groupErrors item = mapError $ \es -> case allErrors es of | |||
Group Nothing es' :| [] -> singleError $ Group (item ^? location) es' | |||
Group (Just _) _ :| [] -> es | |||
_ -> singleError $ Group (item ^? location) es | |||
-- | Lift a single 'Error' into an 'ErrorSet'. | |||
singleError :: Hashable e => Error e -> ErrorSet e | |||
singleError = ErrorSet . singleton | |||
{-# INLINE singleError #-} | |||
-- | Lift a custom error into an 'ErrorSet'. | |||
customError :: Hashable e => e -> ErrorSet e | |||
customError = singleError . Custom | |||
{-# INLINE customError #-} | |||
-- | Throw a single error. | |||
liftError1 :: (IsError e, ApErrors e m) => Error e -> m a | |||
liftError1 = liftError . singleError | |||
{-# INLINE liftError1 #-} | |||
-- | Return the set of errors in an 'ErrorSet' as a non-empty list. | |||
allErrors :: ErrorSet e -> NonEmpty (Error e) | |||
allErrors (ErrorSet hs) = | |||
maybe (error "unexpected empty ErrorSet") id . nonEmpty $ toList hs |
@ -1,82 +0,0 @@ | |||
{-| | |||
Module : Prosidy.Compile.FromSetting | |||
Description : Typeclass for parsing values from Prosidy settings. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DataKinds #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |||
{-# LANGUAGE KindSignatures #-} | |||
{-# LANGUAGE MagicHash #-} | |||
{-# LANGUAGE ScopedTypeVariables #-} | |||
{-# LANGUAGE TypeApplications #-} | |||
{-# LANGUAGE UndecidableInstances #-} | |||
module Prosidy.Compile.FromSetting (FromSetting(..), Sep(..)) where | |||
import Data.Bifunctor ( first ) | |||
import Data.Text ( Text ) | |||
import Text.Read ( readEither ) | |||
import Type.Reflection ( Typeable | |||
, typeRep | |||
) | |||
import GHC.TypeLits ( KnownSymbol | |||
, Symbol | |||
, symbolVal' | |||
) | |||
import GHC.Exts ( Proxy# | |||
, proxy# | |||
) | |||
import qualified Data.Text as Text | |||
import qualified Data.Text.Lazy as Text.Lazy | |||
-- | A typeclass for parsing Prosidy settings into typed values. A default | |||
-- instance exists for all types implementing 'Read'. | |||
class FromSetting a where | |||
-- | Given a 'Text' value containing the setting, either parse a value | |||
-- or return an error message explaining why the value is malformed. | |||
fromSetting :: Text -> Either String a | |||
instance FromSetting [Char] where | |||
fromSetting = Right . Text.unpack | |||
{-# INLINE fromSetting #-} | |||
instance FromSetting Text where | |||
fromSetting = Right | |||
{-# INLINE fromSetting #-} | |||
instance FromSetting Text.Lazy.Text where | |||
fromSetting = Right . Text.Lazy.fromStrict | |||
{-# INLINE fromSetting #-} | |||
instance {-# OVERLAPPABLE #-} (Typeable a, Read a) => FromSetting a where | |||
fromSetting txt = first err . readEither . Text.unpack $ txt | |||
where | |||
err = mconcat | |||
[ showString "failed to parse the string " | |||
, shows txt | |||
, showString " as a value of type " | |||
, shows (typeRep @a) | |||
, showString ": " | |||
] | |||
------------------------------------------------------------------------------- | |||
-- | A newtype wrapper for reading in a delimited list of values. The @delim@ | |||
-- parameter is a type-level string specifying the seperator between values. | |||
-- It must not be empty, or parsing will fail to terminate. | |||
-- | |||
-- Sep does not handle escaping or other fancy processing. | |||
newtype Sep (delim :: Symbol) a = Sep { unsep :: [a] } | |||
deriving (Show, Eq, Semigroup, Monoid, Functor, Applicative, Monad, Foldable) | |||
instance Traversable (Sep delim) where | |||
traverse f = fmap Sep . traverse f . unsep | |||
instance (KnownSymbol delim, FromSetting a) => FromSetting (Sep delim a) where | |||
fromSetting = | |||
fmap Sep | |||
. traverse fromSetting | |||
. filter (not . Text.null) | |||
. Text.splitOn (Text.pack $ symbolVal' (proxy# :: Proxy# delim)) |
@ -1,123 +0,0 @@ | |||
{-| | |||
Module : Prosidy.Compile.Match | |||
Description : Fallible pattern rules. | |||
Copyright : ©2020 James Alexander Feldman-Crough | |||
License : MPL-2.0 | |||
Maintainer : alex@fldcr.com | |||
-} | |||
{-# LANGUAGE DerivingVia #-} | |||
module Prosidy.Compile.Match | |||
( -- * DSL for matching cases | |||
Match | |||
, MatchM | |||
, match | |||
-- ** Specific matchers | |||
, break | |||
, breakWith | |||
, paragraph | |||
, text | |||
-- *** Tag matchers which strictly enforce metadata. | |||
, blockTag | |||
, inlineTag | |||
, literalTag | |||
-- *** Tag matchers which loosely enforce metadata. | |||
, blockTag' | |||
, inlineTag' | |||
, literalTag' | |||
) | |||
where | |||
import Prelude hiding ( break ) | |||
import Prosidy.Compile.Core | |||
import Prosidy.Compile.Error | |||
import Prosidy.Compile.Strict | |||
import Control.Monad.State ( StateT(..) | |||
, State | |||
, modify' | |||
, execState | |||
) | |||
import Data.Monoid ( Endo(..) ) | |||
import Data.Text ( Text ) | |||
import Data.List.NonEmpty ( NonEmpty(..) ) | |||
import qualified Prosidy as P | |||
-- | The type of fallible pattern specifications. | |||
type Match i e f a = MatchM i e a f () | |||
-- | A monadic interface for defining fallible patterns. In practice, @r@ will | |||
-- always be instantiated to @()@— 'Match' can be more clear. | |||
newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r) | |||
deriving (Functor, Applicative, Monad) | |||
via State (Endo [Pattern i e f a]) | |||
-- | Finalize a 'Match' into a rule. This is often used to offset a match | |||
-- block: | |||
-- | |||
-- @ | |||
-- blocktags :: Match Block Void Identity String | |||
-- blocktags = match $ do | |||
-- ... | |||
-- @ | |||
match :: (Applicative f, CanMatch i) => Match i e f a -> RuleT i e f a | |||
match (MatchM s) = case appEndo (execState s mempty) [] of | |||
x : xs -> rule . TestMatch $ x :| xs | |||
[] -> rule $ Fail EmptyMatch | |||
-- | Match against a 'Prosidy.Typs.Break'. | |||
break :: RuleT () e f a -> Match P.Inline e f a | |||
break = put . BreakP | |||
-- | Replace all 'Prosidy.Types.Break's with the provided value. | |||
breakWith :: a -> Match P.Inline e f a | |||
breakWith = put . BreakP . pure | |||
-- | Match 'Prosidy.Types.Paragraph's in a block context. | |||
paragraph :: RuleT (P.SeriesNE P.Inline) e f a -> Match P.Block e f a | |||
paragraph = put . ParagraphP | |||
-- | Match plain 'Text' in an inline context. | |||
text :: RuleT Text e f a -> Match P.Inline e f a | |||
text = put . TextP | |||
put :: Pattern i e f a -> Match i e f a | |||
put x = MatchM $ modify' (<> Endo (x :)) | |||
------------------------------------------------------------------------------- | |||
-- | Strict: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'. | |||
blockTag | |||
:: Applicative f => P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a | |||
blockTag key = put . BlockTagP key . strict | |||
-- | Strict: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'. | |||
inlineTag | |||
:: Applicative f | |||
=> P.Key | |||
-> RuleT InlineRegion e f a | |||
-> Match P.Inline e f a | |||
inlineTag key = put . InlineTagP key . strict | |||
-- | Strict: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'. | |||
literalTag |