Browse Source

Usability refactor (#2)

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: #2
master
James Alexander Feldman-Crough 1 year ago
parent
commit
3d79cae227
  1. 33
      prosidyc.cabal
  2. 82
      src/Data/Either/Valid.hs
  3. 89
      src/Data/Void/HKT.hs
  4. 108
      src/Prosidy/Compile.hs
  5. 286
      src/Prosidy/Compile/Core.hs
  6. 68
      src/Prosidy/Compile/Core/Interpret.hs
  7. 291
      src/Prosidy/Compile/Core/Rules.hs
  8. 271
      src/Prosidy/Compile/DSL.hs
  9. 220
      src/Prosidy/Compile/Error.hs
  10. 82
      src/Prosidy/Compile/FromSetting.hs
  11. 123
      src/Prosidy/Compile/Match.hs
  12. 492
      src/Prosidy/Compile/Run.hs
  13. 146
      src/Prosidy/Compile/Strict.hs

33
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 @@ library
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
-------------------------------------------------------------------------------

82
src/Data/Either/Valid.hs

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

89
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

108
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
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

286
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
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

68
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

291
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

271
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

220
src/Prosidy/Compile/Error.hs

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

82
src/Prosidy/Compile/FromSetting.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))

123
src/Prosidy/Compile/Match.hs

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