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
9 months ago · 3d79cae227
--- a/prosidyc.cabal
+++ b/prosidyc.cabal
@ -1,6 +1,6 @@
 cabal-version:       2.4
 name:                prosidyc
 version:             0.2.0.0
 version:             0.3.0.0
 synopsis:            A DSL for processing Prosidy documents.
 license:             MPL-2.0
 license-file:        LICENSE
@ -43,20 +43,25 @@ 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

 -------------------------------------------------------------------------------
--- a/src/Data/Either/Valid.hs
+++ b/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 #-}
--- a/src/Data/Void/HKT.hs
+++ b/src/Data/Void/HKT.hs
@ -0,0 +1,89 @@
 {-|
 Module      : Data.Void.HKT
 Description : A poly-kinded uninhabited type.
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# OPTIONS_GHC -Wno-unused-binds #-}
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE PolyKinds #-}
 module Data.Void.HKT (Void, Uninhabited(..)) where

 import           Data.Profunctor                ( Profunctor(..)
                                                , Strong(..)
                                                , Choice(..)
                                                )
 import           Data.Bifunctor                 ( Bifunctor(..) )

 -- | A poly-kinded, uninhabited type family.
 data family Void :: k

 -- | The uninhabited type taking no arguments.
 data instance Void

 -- | The uninhabited type taking one argument.
 newtype instance Void (a :: ka) = Void1 Void

 -- | The uninhabited type taking two arguments.
 newtype instance Void (a :: ka) (b :: kb) = Void2 Void

 -- | The uninhabited type taking three arguments.
 newtype instance Void (a :: ka) (b :: kb) (c :: kc) = Void3 Void

 -- | Defines uninhabited types.
 class Uninhabited a where
    -- | If @a@ is an uninhabited type, we will never receive a value of type
    -- @a@ and thus we can return a value of any type.
    absurd :: a -> b

 instance Uninhabited Void where
    absurd = \case {}

 instance Uninhabited (Void a) where
    absurd = \case {}

 instance Uninhabited (Void a b) where
    absurd = \case {}

 instance Uninhabited (Void a b c) where
    absurd = \case {}

 instance Functor Void where
    fmap = const absurd

 instance Functor (Void a) where
    fmap = const absurd

 instance Functor (Void a b) where
    fmap = const absurd

 instance Bifunctor Void where
    bimap = const (const absurd)

 instance Bifunctor (Void a) where
    bimap = const (const absurd)

 instance Profunctor Void where
    dimap = const (const absurd)

 instance Profunctor (Void a) where
    dimap = const (const absurd)

 instance Strong Void where
    first'  = absurd
    second' = absurd

 instance Strong (Void a) where
    first'  = absurd
    second' = absurd

 instance Choice Void where
    left'  = absurd
    right' = absurd

 instance Choice (Void a) where
    left'  = absurd
    right' = absurd
--- a/src/Prosidy/Compile.hs
+++ b/src/Prosidy/Compile.hs
@ -1,110 +1,12 @@
 {-|
 Module      : Prosidy.Compile
 Description : Compile Prosidy documents into other shapes
 Description : Reexport module. You probable want to import this.
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Prosidy.Compile
    ( escapeHatch
    , getContent
    , matchContent
    , optParse
    , prop
    , reqParse
    , traversing
    , self
    , strict
    , RuleT
    , Rule
    , CanMatch
    , Error(..)
    , ErrorSet
    , Error'
    , ErrorSet'
    , FromSetting(..)
    , req
    , opt
    , module Prosidy.Compile.Match
    , module Prosidy.Compile.Run
    )
 where
 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
--- a/src/Prosidy/Compile/Core.hs
+++ b/src/Prosidy/Compile/Core.hs
@ -1,286 +1,12 @@
 {-|
 Module      : Prosidy.Compile.Core
 Description : Primitive type definitions and functions.
 Module      : Prosidy.Compile.Core.Rule
 Description : Basic contextual compilation rules 
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE LambdaCase #-}
 module Prosidy.Compile.Core
    ( RuleF(..)
    , RuleT
    , Rule
    , CanMatch(evalPattern, noMatchError)
    , Pattern(..)
    , Interpret
    , BlockRegion
    , InlineRegion
    , LiteralRegion
    , interpretWith
    , evalPatterns
    , rule
    )
 where
 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
--- a/src/Prosidy/Compile/Core/Interpret.hs
+++ b/src/Prosidy/Compile/Core/Interpret.hs
@ -0,0 +1,68 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-|
 Module      : Prosidy.Compile.Core.Interpret
 Description : Internal module declaring the 'Context' and 'Interpret' classes. 
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE TypeFamilies #-}
 module Prosidy.Compile.Core.Interpret
    ( Context(..)
    , Interpret(..)
    , interpret
    )
 where

 import           Control.Applicative            ( Alternative )
 import           Prosidy.Compile.Core.Rules     ( RuleFor
                                                , Rules
                                                , Rule(..)
                                                , runRules
                                                )
 import           Data.Void.HKT                  ( Void
                                                , absurd
                                                )

 -- | A base class for interpreters of 'Rules'.
 class (forall i. Alternative (t i)) => Context t where
    -- | Access the current focus of an interpreter. This function is similar
    -- in purpose to 'Control.Monad.Trans.Reader.ask'.
    runSelf :: t i i

    -- | A type for expressions that can be lifted by the interpreter.
    --
    -- This type defaults to an uninhabited type. Only override this type
    -- if you intend on overriding 'liftRule', as well.
    type Local t :: * -> *

    -- | Lift an expression of type 'Local' into the interpreter. 
    --
    -- By default, 'Local' is left as an uninhabted type and escaping via
    -- 'liftRule' can never happen. Override both 'Local' and 'liftRule' to
    -- permit arbitrary computation.
    liftRule :: Local t a -> t i a

    type Local t = Void t
    default liftRule :: Local t a ~ Void t a => Local t a -> t i a
    liftRule = absurd

 -- | Instructs a 'Context' how to interpret a single rule.
 class Context t => Interpret t i where
    -- | Evaluate a single rule into the context.
    runRule :: RuleFor i (Local t) a -> t i a

    default runRule :: (RuleFor i ~ Void i) => RuleFor i (Local t) a -> t i a
    runRule = absurd

 -- | Evaluate 'Rules' into a contextual interpreter.
 interpret :: forall t i a. Interpret t i => Rules i (Local t) a -> t i a
 interpret = runRules $ \x -> case x of
    RuleFor r -> runRule r
    Escape  f -> liftRule f
    Self    s -> s <$> runSelf
--- a/src/Prosidy/Compile/Core/Rules.hs
+++ b/src/Prosidy/Compile/Core/Rules.hs
@ -0,0 +1,291 @@
 {-|
 Module      : Prosidy.Compile.Core.Rules
 Description : Internal module declaring 'Rules' types and functions.
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Prosidy.Compile.Core.Rules
    ( Rules
    , Rule(..)
    , rule
    , local
    , self
    , runRules
    , mapRules
    , hoist

    , HoistRuleFor

    -- * Context-aware ADT rules.
    , RuleFor
    , BlockRule(..)
    , DocumentRule(..)
    , FragmentRule(..)
    , InlineRule(..)
    , MetadataRule(..)
    , ParagraphRule(..)
    , RegionRule(..)
    , SeriesNERule(..)
    , SeriesRule(..)
    , TagRule(..)

    -- * Reëxports
    , Alternative(..)
    )
 where

 import           Prosidy.Types
 import           Prosidy.Source                 ( Location )
 import           Data.Void.HKT                  ( Void )
 import           Data.Text                      ( Text )

 import           Control.Applicative            ( Alternative(..) )
 import qualified Control.Alternative.Free.Final
                                               as Alt

 -------------------------------------------------------------------------------
 -- | A container for building up compilation rules.
 --
 -- * The type parameter @t@ specifies the /input type/ of these rules. It will
 -- almost always be a Prosidy node type, such as 'Document' or 'Tag'.
 --
 -- * The type parameter @f@ is a contextual functor for implementing custom
 -- extensions on top of 'Rules'.
 newtype Rules t f a = Rules
  { _runRules :: Alt.Alt (Rule t f) a
  }
  deriving newtype (Functor, Applicative, Alternative, Semigroup, Monoid)

 -- | Lift a single rule into the 'Rules' functor.
 rule :: RuleFor t f a -> Rules t f a
 rule = Rules . Alt.liftAlt . RuleFor

 -- | Lift a contextual item into 'Rules'.
 local :: Functor f => f a -> Rules t f a
 local = Rules . Alt.liftAlt . Escape

 -- | Get the currently focused node as a value.
 self :: Rules t f t
 self = Rules . Alt.liftAlt $ Self id

 -- | Given an interpreter which can convert 'Rule's into the functor @g@,
 -- convert 'Rules' into the functor @g@.
 runRules
    :: Alternative g => (forall b . Rule t f b -> g b) -> Rules t f a -> g a
 runRules interpret = Alt.runAlt interpret . _runRules

 -- | Map over the contextual functor @f@ in 'Rules'.
 hoist :: HoistRuleFor t => (forall b. f b -> g b) -> Rules t f a -> Rules t g a
 hoist fToG = Rules . Alt.hoistAlt (hoistRule fToG) . _runRules

 -- | Map over 'Rules'.
 mapRules
    :: forall a a' t t' f
     . (Functor f, Functor (RuleFor t' f))
    => (forall x . RuleFor t f x -> RuleFor t' f x)
      -- ^ Maps over rules themselves, keeping the context and output types the
      -- same.
    -> (t' -> t)
      -- ^ Maps over the input to rules.
    -> (a -> a')
      -- ^ Maps over the output of rules.
    -> Rules t f a
    -> Rules t' f a'
 mapRules f g h (Rules alt) = Rules $ h <$> Alt.hoistAlt (mapRule f g id) alt

 -------------------------------------------------------------------------------
 -- | An individual 'Rule' in isolation.
 data Rule t f a =
    RuleFor (RuleFor t f a)   -- ^ A rule specific to the input type @t@
  | Escape  (f a) -- ^ An escape hatch, allowing arbitrary computation
  | Self    (t -> a)          -- ^ A rule which converts the input type to an output.

 instance (Functor f, Functor (RuleFor t f)) => Functor (Rule t f) where
    fmap fn x = case x of
        RuleFor rule -> RuleFor $ fn <$> rule
        Escape  rule -> Escape $ fn <$> rule
        Self    self -> Self $ fn <$> self

 hoistRule :: HoistRuleFor t => (forall b. f b -> g b) -> Rule t f a -> Rule t g a
 hoistRule f (RuleFor rf) = RuleFor (hoistRuleFor f rf)
 hoistRule f (Escape fa)  = Escape (f fa)
 hoistRule _ (Self fn)    = Self fn

 mapRule
    :: (Functor f, Functor (RuleFor t' f))
    => (forall x . RuleFor t f x -> RuleFor t' f x)
    -> (t' -> t)
    -> (a -> a')
    -> Rule t f a
    -> Rule t' f a'
 mapRule f _ h (RuleFor r   ) = RuleFor . fmap h . f $ r
 mapRule _ _ h (Escape  es  ) = Escape $ h <$> es
 mapRule _ g h (Self    self) = Self $ h . self . g

 -------------------------------------------------------------------------------
 -- | Defines a relationship between input types and rules specific to those
 -- input types.
 type family RuleFor t = (rule :: (* -> *) -> * -> *) | rule -> t where
  RuleFor Block        = BlockRule
  RuleFor Document     = DocumentRule
  RuleFor Fragment     = FragmentRule
  RuleFor Inline       = InlineRule
  RuleFor Metadata     = MetadataRule
  RuleFor Paragraph    = ParagraphRule
  RuleFor (Region   a) = RegionRule   a
  RuleFor (Series   a) = SeriesRule   a
  RuleFor (SeriesNE a) = SeriesNERule a
  RuleFor (Tag      a) = TagRule      a
  RuleFor           a  = Void         a

 -- | A class defining how to map over the contextual parameter @f@ in a rule for
 -- the type @t@.
 class HoistRuleFor t where
    hoistRuleFor :: (forall b. f b -> g b) -> RuleFor t f a -> RuleFor t g a

 -------------------------------------------------------------------------------
 -- | Rules for matching specific types of 'Block' nodes.
 data BlockRule f a =
    BlockRuleBlockTag   (Rules BlockTag   f a)
  | BlockRuleLiteralTag (Rules LiteralTag f a)
  | BlockRuleParagraph  (Rules Paragraph  f a)
  deriving stock Functor

 instance HoistRuleFor Block where
    hoistRuleFor f = \case
        BlockRuleBlockTag rules -> BlockRuleBlockTag $ hoist f rules
        BlockRuleLiteralTag rules -> BlockRuleLiteralTag $ hoist f rules
        BlockRuleParagraph rules -> BlockRuleParagraph $ hoist f rules

 -------------------------------------------------------------------------------
 -- | Rules applying to 'Document's.
 newtype DocumentRule f a =
    DocumentRule (RegionRule (Series Block) f a)
  deriving newtype Functor

 instance HoistRuleFor Document where
    hoistRuleFor f = \case 
        DocumentRule r -> DocumentRule $ hoistRuleFor f r

 -------------------------------------------------------------------------------
 -- | Rules applying to 'Fragment's (i.e. plain text).
 data FragmentRule f a =
    FragmentRuleLocation (Maybe Location -> a)
  | FragmentRuleText     (Text           -> a)
  deriving stock Functor

 instance HoistRuleFor Fragment where
    hoistRuleFor _ = \case
        FragmentRuleLocation fn -> FragmentRuleLocation fn
        FragmentRuleText fn -> FragmentRuleText fn

 -------------------------------------------------------------------------------
 -- | Rules for matching specific types of 'Inline' nodes.
 data InlineRule f a =
    InlineRuleBreak     a
  | InlineRuleFragment  (Rules Fragment  f a)
  | InlineRuleInlineTag (Rules InlineTag f a)
  deriving stock Functor

 instance HoistRuleFor Inline where
    hoistRuleFor f = \case
        InlineRuleBreak a -> InlineRuleBreak a
        InlineRuleFragment rules -> InlineRuleFragment $ hoist f rules
        InlineRuleInlineTag rules -> InlineRuleInlineTag $ hoist f rules

 -------------------------------------------------------------------------------
 -- | Rules for operating on properties and settings.
 data MetadataRule f a =
    MetadataRuleProperty (Bool -> a) Key
  | MetadataRuleSetting  (Text -> Either String a) (Maybe a) Key
  | MetadataRuleAllowUnknown a
  deriving stock Functor

 instance HoistRuleFor Metadata where
    hoistRuleFor _ = \case
        MetadataRuleProperty fn key -> MetadataRuleProperty fn key
        MetadataRuleSetting fn def key -> MetadataRuleSetting fn def key
        MetadataRuleAllowUnknown a -> MetadataRuleAllowUnknown a

 -------------------------------------------------------------------------------
 -- | Rules for accessing paragraphs.
 data ParagraphRule f a =
    ParagraphRuleContent  (Rules (SeriesNE Inline) f a)
  | ParagraphRuleLocation (Maybe Location -> a)
  deriving stock Functor

 instance HoistRuleFor Paragraph where
    hoistRuleFor f = \case
        ParagraphRuleContent rules -> ParagraphRuleContent $ hoist f rules
        ParagraphRuleLocation fn -> ParagraphRuleLocation fn

 -------------------------------------------------------------------------------
 -- | Rules for operating on a 'Region'.
 data RegionRule t f a =
    RegionRuleLocation (Maybe Location -> a)
  | RegionRuleMetadata (MetadataRule f a)
  | RegionRuleContent  (Rules t f a)
  deriving stock Functor

 instance HoistRuleFor t => HoistRuleFor (Region t) where
    hoistRuleFor f = \case
        RegionRuleLocation fn   -> RegionRuleLocation fn
        RegionRuleMetadata rule -> RegionRuleMetadata $ hoistRuleFor f rule
        RegionRuleContent rules -> RegionRuleContent $ hoist f rules

 -------------------------------------------------------------------------------
 -- | Operates sequentially against a collection of nodes.
 data SeriesRule t f a =
    SeriesRuleNext (SeriesNERule t f a)
  | SeriesRuleEmpty a

 instance Functor (SeriesRule t f) where
    fmap fn (SeriesRuleNext  rule) = SeriesRuleNext (fmap fn rule)
    fmap fn (SeriesRuleEmpty x   ) = SeriesRuleEmpty (fn x)

 instance HoistRuleFor t => HoistRuleFor (Series t) where
    hoistRuleFor f = \case
        SeriesRuleNext rule -> SeriesRuleNext $ hoistRuleFor f rule
        SeriesRuleEmpty a -> SeriesRuleEmpty a

 -------------------------------------------------------------------------------
 -- | Operates sequentially against a non-empty collection of nodes.
 data SeriesNERule t f a =
    forall b c. SeriesNERule (b -> c -> a) (Rules t f b) (Rules (Series t) f c)

 instance Functor (SeriesNERule t f) where
    fmap fn (SeriesNERule k rule next) = SeriesNERule (fmap fn . k) rule next

 instance HoistRuleFor t => HoistRuleFor (SeriesNE t) where
    hoistRuleFor f = \case
        SeriesNERule k r1 rs -> SeriesNERule k (hoist f r1) (hoist f rs)

 -------------------------------------------------------------------------------
 -- | Rules for operating on 'Tag's.
 data TagRule t f a =
    TagRuleKey Key a
  | TagRuleRegion (RegionRule t f a)
  deriving stock Functor

 instance HoistRuleFor t => HoistRuleFor (Tag t) where
    hoistRuleFor f = \case
        TagRuleKey k a -> TagRuleKey k a
        TagRuleRegion rule -> TagRuleRegion $ hoistRuleFor f rule

 -------------------------------------------------------------------------------
 instance HoistRuleFor Text where
    hoistRuleFor _ = \case
--- a/src/Prosidy/Compile/DSL.hs
+++ b/src/Prosidy/Compile/DSL.hs
@ -0,0 +1,271 @@
 {-|
 Module      : Prosidy.Compile.DSL
 Description : An EDSL for declaring 'Prosidy.Compile.Core.Rules'.
 Copyright   : ©2020 James Alexander Feldman-Crough
 License     : MPL-2.0
 Maintainer  : alex@fldcr.com
 -}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
 module Prosidy.Compile.DSL
    ( content
      -- * Series rules
    , (&>)
    , (&>>)
    , folded
    , folded1
    , collect
    , end
    , endWith
      -- * Metadata rules
    , prop
    , req
    , opt
    , lax
      -- * Matchers
    , Match
    , match
    , blockTag
    , inlineTag
    , literalTag
    , paragraph
    , text
    , breakWith
      -- * Get wild with actions
    , local
    , self
    , hoist
      -- * Convenience classes
    , FromSetting(..)
    , RegionLike
    )
 where

 import qualified Prosidy
 import           Prosidy.Types.Series           ( pattern Empty
                                                , pattern (:<:)
                                                , pattern (:<<:)
                                                )
 import           Prosidy.Compile.Core
 import           Data.Monoid                    ( Alt(..) )
 import           Text.Read                      ( readMaybe )
 import           Type.Reflection                ( Typeable
                                                , typeRep
                                                )
 import           Data.Text                      ( Text )
 import qualified Data.Text                     as Text
 import qualified Data.Text.Lazy                as Text.Lazy
 import           Numeric.Natural                ( Natural )

 infixr 3 &>
 infixr 1 &>>

 -------------------------------------------------------------------------------
 -- | Access the inner content of the 'RegionLike' value @t@. 
 content :: RegionLike t => Rules (Prosidy.Content t) f a -> Rules t f a
 content = rule . liftRegionRule . RegionRuleContent

 -------------------------------------------------------------------------------
 -- | Given a 'Prosidy.Series', perform the rule on the left hand side on the
 -- first element of the 'Prosidy.Series', and the rule on the right hand side
 -- on all items after the first.
 --
 -- This can be used to define rules which must be evaluated sequentially.
 (&>)
    :: Rules t f a
    -> Rules (Prosidy.Series t) f (Prosidy.Series a)
    -> Rules (Prosidy.Series t) f (Prosidy.Series a)
 r &> rs = rule . SeriesRuleNext $ SeriesNERule (:<:) r rs

 -- | Like '(&>)', but returns a combined rule which operates on a non-empty
 -- series ('Prosidy.SeriesNE').
 (&>>)
    :: Rules t f a
    -> Rules (Prosidy.Series t) f (Prosidy.Series a)
    -> Rules (Prosidy.SeriesNE t) f (Prosidy.SeriesNE a)
 r &>> rs = rule $ SeriesNERule (:<<:) r rs

 -- | Match the end of a 'Prosidy.Series'.
 end :: Rules (Prosidy.Series t) f (Prosidy.Series a)
 end = endWith Empty

 -- | Match the end of a 'Prosidy.Series', returning the provided value.
 endWith :: a -> Rules (Prosidy.Series t) f a
 endWith = rule . SeriesRuleEmpty

 -- | Lift a rule to collect many of that rule in series
 collect :: Rules t f a -> Rules (Prosidy.Series t) f (Prosidy.Series a)
 collect rules = go
  where
    go = (rules &> go) <|> end

 -- | Lift a rule to operate on a 'Prosidy.Series' by folding the results of
 -- evaluation against each element into a single result.
 folded :: Monoid a => Rules t f a -> Rules (Prosidy.Series t) f a
 folded r = go
  where
    go = rule (SeriesRuleNext $ SeriesNERule (<>) r go)
        <|> rule (SeriesRuleEmpty mempty)

 -- | Like 'folded', but operates on a non-empty series.    
 folded1 :: Monoid a => Rules t f a -> Rules (Prosidy.SeriesNE t) f a
 folded1 r = rule $ SeriesNERule (<>) r (folded r)

 -------------------------------------------------------------------------------
 -- | A class for recursive nodes in a document.
 class Prosidy.HasContent t => RegionLike t where
    liftRegionRule :: RegionRule (Prosidy.Content t) f a -> RuleFor t f a

 instance RegionLike Prosidy.Document where
    liftRegionRule = DocumentRule

 instance RegionLike (Prosidy.Tag t) where
    liftRegionRule = TagRuleRegion

 instance RegionLike (Prosidy.Region t) where
    liftRegionRule = id

 -- | Check if a 'Prosidy.Metadata' property is set on a node.
 prop :: RegionLike t => Prosidy.Key -> Rules t f Bool
 prop = rule . liftRegionRule . RegionRuleMetadata . MetadataRuleProperty id

 -- | Fetch a /required/ 'Prosidy.Metadata' value from a node, parsing it using
 -- the provided function.
 reqWith
    :: forall a t f. RegionLike t => (Text -> Either String a) -> Prosidy.Key -> Rules t f a
 reqWith parse =
    rule
        . liftRegionRule
        . RegionRuleMetadata
        . MetadataRuleSetting parse Nothing

 -- | Fetch a /required/ 'Prosidy.Metadata' setting from a node.
 req :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f a
 req = reqWith parseSetting

 -- | Fetch an /optional/ 'Prosidy.Metadata' value from a node, parsing it using
 -- the provided function.
 optWith
    :: forall a t f. RegionLike t
    => (Text -> Either String a)
    -> Prosidy.Key
    -> Rules t f (Maybe a)
 optWith parse =
    rule . liftRegionRule . RegionRuleMetadata . MetadataRuleSetting
        (fmap Just . parse)
        (Just Nothing)

 -- | Fetch an /optional/ 'Prosidy.Metadata' setting from a node.
 opt :: forall a t f. (RegionLike t, FromSetting a) => Prosidy.Key -> Rules t f (Maybe a)
 opt = optWith parseSetting

 -- | Allow unknown properties and settings in this region.
 lax :: RegionLike t => Rules t f ()
 lax = rule . liftRegionRule . RegionRuleMetadata $ MetadataRuleAllowUnknown ()

 -------------------------------------------------------------------------------
 -- | A class for values which can be parsed from 'Text'.
 class FromSetting a where
    parseSetting :: Text -> Either String a

    default parseSetting :: (Typeable a, Read a) => Text -> Either String a
    parseSetting raw = case readMaybe (Text.unpack raw) of
        Just ok -> Right ok
        Nothing -> Left $ "Failed to parse " <> show raw <> " as type " <> show (typeRep @a)

 instance FromSetting Double
 instance FromSetting Float
 instance FromSetting Int
 instance FromSetting Integer
 instance FromSetting Natural
 instance FromSetting Word

 instance FromSetting String where
    parseSetting = Right . Text.unpack

 instance FromSetting Text where
    parseSetting = Right
    {-# INLINE parseSetting #-}

 instance FromSetting Text.Lazy.Text where
    parseSetting = Right . Text.Lazy.fromStrict
    {-# INLINE parseSetting #-}

 -------------------------------------------------------------------------------
 -- | A type used to declare alternatives in @do@ notation.
 type Match t f a = MatchM t f a ()

 data MatchM t f a r = MatchM !(Alt (Rules t f) a) !r

 instance Semigroup r => Semigroup (MatchM t a f r) where
    MatchM r a <> MatchM s b = MatchM (r <> s) (a <> b)

 instance Monoid r => Monoid (MatchM t a f r) where
    mempty = MatchM mempty mempty

 instance Functor (MatchM t f a) where
    fmap fn (MatchM r x) = MatchM r (fn x)

 instance Applicative (MatchM t f a) where
    pure = MatchM mempty
    MatchM lhs fn <*> MatchM rhs x = MatchM (lhs <> rhs) (fn x)

 instance Monad (MatchM t f a) where
    MatchM lhs x >>= f = let MatchM rhs x' = f x in MatchM (lhs <> rhs) x'

 -- | Lifts a 'Match' into 'Rules' by trying each defined pattern, from top to
 -- bottom, until a match is found.
 match :: Match t f a -> Rules t f a
 match (MatchM (Alt r) ()) = r

 -- | Match a 'Prosidy.BlockTag' with the proided 'Prosidy.Key'.
 blockTag
    :: Functor f
    => Prosidy.Key
    -> Rules Prosidy.BlockRegion f a
    -> Match Prosidy.Block f a
 blockTag key = matchRule . BlockRuleBlockTag . tagRule key

 -- | Match a 'Prosidy.LiteralTag' with the provided 'Prosidy.Key'.
 literalTag
    :: Functor f
    => Prosidy.Key
    -> Rules Prosidy.LiteralRegion f a
    -> Match Prosidy.Block f a
 literalTag key = matchRule . BlockRuleLiteralTag . tagRule key

 -- | Match a 'Prosidy.InlineTag' with the provided 'Prosidy.Key'.
 inlineTag
    :: Functor f
    => Prosidy.Key
    -> Rules Prosidy.InlineRegion f a
    -> Match Prosidy.Inline f a
 inlineTag key = matchRule . InlineRuleInlineTag . tagRule key

 -- | Match a paragraph which is not enclosed in a tag.
 paragraph
    :: Rules (Prosidy.SeriesNE Prosidy.Inline) f a -> Match Prosidy.Block f a
 paragraph = matchRule . BlockRuleParagraph . rule . ParagraphRuleContent

 -- | Match textual content, transforming it with the provided function.
 text :: (Text -> a) -> Match Prosidy.Inline f a
 text = matchRule . InlineRuleFragment . rule . FragmentRuleText

 -- | Replace inline breaks with the provided vlaue.
 breakWith :: a -> Match Prosidy.Inline f a
 breakWith = matchRule . InlineRuleBreak

 matchRule :: RuleFor t f a -> Match t f a
 matchRule = flip MatchM () . Alt . rule

 tagRule
    :: Functor f
    => Prosidy.Key
    -> Rules (Prosidy.Region t) f a
    -> Rules (Prosidy.Tag t) f a
 tagRule key r =
    rule (TagRuleKey key ()) *> mapRules liftRegionRule Prosidy.tagToRegion id r
--- a/src/Prosidy/Compile/Error.hs
+++ b/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
--- a/src/Prosidy/Compile/FromSetting.hs
+++ b/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))
--- a/src/Prosidy/Compile/Match.hs
+++ b/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(..) )

 import qualified Prosidy                       as P

 -- | The type of fallible pattern specifications.
 type Match i e f a = MatchM i e a f ()

 -- | A monadic interface for defining fallible patterns. In practice, @r@ will
 -- always be instantiated to @()@— 'Match' can be more clear.
 newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r)
  deriving (Functor, Applicative, Monad)
    via State (Endo [Pattern i e f a])

 -- | Finalize a 'Match' into a rule. This is often used to offset a match
 -- block:
 --
 -- @
 -- blocktags :: Match Block Void Identity String
 -- blocktags = match $ do
 --    ...
 -- @
 match :: (Applicative f, CanMatch i) => Match i e f a -> RuleT i e f a
 match (MatchM s) = case appEndo (execState s mempty) [] of
    x : xs -> rule . TestMatch $ x :| xs
    []     -> rule $ Fail EmptyMatch

 -- | Match against a 'Prosidy.Typs.Break'.
 break :: RuleT () e f a -> Match P.Inline e f a
 break = put . BreakP

 -- | Replace all 'Prosidy.Types.Break's with the provided value.
 breakWith :: a -> Match P.Inline e f a
 breakWith = put . BreakP . pure

 -- | Match 'Prosidy.Types.Paragraph's in a block context.
 paragraph :: RuleT (P.SeriesNE P.Inline) e f a -> Match P.Block e f a
 paragraph = put . ParagraphP

 -- | Match plain 'Text' in an inline context.
 text :: RuleT Text e f a -> Match P.Inline e f a
 text = put . TextP

 put :: Pattern i e f a -> Match i e f a
 put x = MatchM $ modify' (<> Endo (x :))


 -------------------------------------------------------------------------------
 -- | Strict: match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.
 blockTag
    :: Applicative f => P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a
 blockTag key = put . BlockTagP key . strict

 -- | Strict: match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.
 inlineTag
    :: Applicative f
    => P.Key
    -> RuleT InlineRegion e f a
    -> Match P.Inline e f a
 inlineTag key = put . InlineTagP key . strict

 -- | Strict: match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.
 literalTag