prosidy
/
prosidyc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
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
0e148fbcb8
commit
3d79cae227
13 changed files with 1315 additions and 976 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  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
View File

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

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

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

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

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

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

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

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

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

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

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