{-| Module : Prosidy.Compile.Core Description : Primitive type definitions and functions. Copyright : ©2020 James Alexander Feldman-Crough License : MPL-2.0 Maintainer : alex@fldcr.com -} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} module Prosidy.Compile.Core ( RuleF(..) , RuleT , Rule , CanMatch(evalPattern, noMatchError) , Pattern(..) , Interpret , BlockRegion , InlineRegion , LiteralRegion , interpretWith , evalPatterns , rule ) where import Lens.Micro import Prosidy.Compile.Error import Prosidy ( Key , HasLocation , HasMetadata , HasContent(Content) ) import Data.Text ( Text ) import Data.Bifunctor ( Bifunctor(..) ) import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Monad.Trans ( MonadTrans(..) ) import Data.Functor.Identity ( Identity ) import qualified Prosidy import qualified Control.Applicative.Free.Final as Ap -- | A single compilation rule. Parameterized by the following types: -- -- * @input@: The type of the Prosidy node that is currently accessible. -- -- * @error@: Allows users to specify a custom error type to be used for -- throwing errors. 'Data.Void.Void' can be used to rely solely on -- the errors built into this library. -- -- * @context@: A 'Monad' for performing contextual computation beyond what -- is provided by this library. If additional contextual computation is not -- desired, use 'Data.Functor.Identity.Identity' as the type. -- -- * @output@: The resulting output type. newtype RuleT input error context output = RuleT (Ap.Ap (RuleF input error context) output) deriving (Functor, Applicative) instance MonadTrans (RuleT input error) where lift = rule . Lift . const . fmap Right -- | 'RuleT' without a contextual environment. type Rule input error = RuleT input error Identity -- | Lifts a 'RuleF' into a 'RuleT'. rule :: RuleF i e f o -> RuleT i e f o rule = RuleT . Ap.liftAp -- | The control functor for compiling Prosidy elements. Each action -- corresponds to an action to perform on the @input@ variable. -- -- See 'RuleT' and 'Rule' for use of this type. data RuleF input error context output where -- | Throw an error. Fail ::Error error -> RuleF input error context output -- | Embed a raw action as a rule. Note: Please avoid using this if -- possible: it breaks static introspection! Lift ::(input -> context (Either (Error error) output)) -> RuleF input error context output -- | Given a non-empty list of potential cases, construct a Rule that -- processes any items matching at least one of those cases. TestMatch ::(CanMatch input) => NonEmpty (Pattern input error context output) -> RuleF input error context output Traverse ::Traversable t => (input -> t i) -> (t o -> output) -> RuleT i error context o -> RuleF input error context output -- | When @input@ is a value wrapping some 'Content', enable access to that -- 'Content' by wrapping a 'RuleT'. GetContent ::HasContent input => RuleT (Content input) error context output -> RuleF input error context output -- | Fetch a property from items with metadata. GetProperty ::HasMetadata input => (Bool -> a) -> Key -> RuleF input error context a -- | Fetch an /optional/ setting from items with metadata. GetSetting ::HasMetadata input => (Maybe x -> output) -> Key -> (Text -> Either String x) -> RuleF input error context output -- | Fetch a /required/ setting from items with metadata. GetRequiredSetting ::HasMetadata input => Key -> (Text -> Either String output) -> RuleF input error context output -- | Get the raw text from a 'Text' node. GetSelf ::(input -> output) -> RuleF input error context output instance Functor context => Functor (RuleF input error context) where fmap fn = \case Fail e -> Fail e Lift lift -> Lift $ fmap (fmap fn) . lift TestMatch matches -> TestMatch $ fmap (fmap fn) matches Traverse f g rule -> Traverse f (fn . g) rule GetContent rule -> GetContent $ fmap fn rule GetProperty k key -> GetProperty (fn . k) key GetSetting k key parse -> GetSetting (fn . k) key parse GetRequiredSetting key parse -> GetRequiredSetting key (fmap fn . parse) GetSelf k -> GetSelf (fn . k) ------------------------------------------------------------------------------- -- | A (lawless) typeclass for enabling fallible matching on nodes. -- -- Implementing new instances of this class in library code is *unneccessary* -- and *unsupported*. class (forall i e. Functor (Pattern t i e), HasLocation t) => CanMatch t where -- | A data type representing allowable fallible patterns for @t@. data family Pattern t :: * -> (* -> *) -> * -> * -- | Information about why a @Pattern@ failed to match. data family NoMatch t :: * -- | Attempt to match a pattern against a value. evalPattern :: Applicative g => Pattern t error context output -- ^ The @Pattern@ to match against -> Interpret error context g -- ^ An interpreter for evaluating the match. -> t -- ^ The value to attempt to match against -> Either (NoMatch t) (g output) -- | Lift a @NoMatch@ error into the 'Error' type. noMatchError :: NoMatch t -> Error e instance CanMatch Prosidy.Block where data Pattern Prosidy.Block error context output = BlockTagP Key (RuleT BlockRegion error context output) | LitTagP Key (RuleT LiteralRegion error context output) | ParagraphP (RuleT (Prosidy.SeriesNE Prosidy.Inline) error context output) deriving Functor data NoMatch Prosidy.Block = NoMatchBlockTag Key | NoMatchLitTag Key | NoMatchParagraph evalPattern (BlockTagP key rule) = evalPatternWith (Prosidy._BlockTag . Prosidy.tagged key) (NoMatchBlockTag key) rule evalPattern (LitTagP key rule) = evalPatternWith (Prosidy._BlockLiteral . Prosidy.tagged key) (NoMatchLitTag key) rule evalPattern (ParagraphP rule) = evalPatternWith (Prosidy._BlockParagraph . Prosidy.content) NoMatchParagraph rule noMatchError (NoMatchBlockTag key) = ExpectedTag BlockKind key noMatchError (NoMatchLitTag key) = ExpectedTag LiteralKind key noMatchError NoMatchParagraph = ExpectedParagraph instance CanMatch Prosidy.Inline where data Pattern Prosidy.Inline error context output = InlineTagP Key (RuleT InlineRegion error context output) | BreakP (RuleT () error context output) | TextP (RuleT Text error context output) deriving Functor data NoMatch Prosidy.Inline = NoMatchInlineTag Key | NoMatchBreak | NoMatchText evalPattern (InlineTagP key rule) = evalPatternWith (Prosidy._InlineTag . Prosidy.tagged key) (NoMatchInlineTag key) rule evalPattern (TextP rule) = evalPatternWith (Prosidy._Text . Prosidy.fragment) NoMatchText rule evalPattern (BreakP rule) = evalPatternWith Prosidy._Break NoMatchBreak rule noMatchError (NoMatchInlineTag key) = ExpectedTag InlineKind key noMatchError NoMatchText = ExpectedText noMatchError NoMatchBreak = ExpectedBreak -- | Match one or more patterns, in sequence, against a value. The result from -- the first successful pattern will be returned. Subsequent matches will not -- be tried. evalPatterns :: (CanMatch i, IsError e, ApErrors e g) => NonEmpty (Pattern i e f o) -> Interpret e f g -> i -> g o evalPatterns (x :| xs) interpret input = either liftError id folded where folded = foldr (\pat acc -> doEval pat `orElse` acc) (doEval x) xs doEval pat = first (singleError . noMatchError) $ evalPattern pat interpret input orElse lhs@Right{} _ = lhs orElse (Left lhs) (Left rhs) = Left $ lhs <> rhs orElse _ rhs = rhs evalPatternWith :: Applicative g => Traversal' i j -> e -> RuleT j e' f o -> Interpret e' f g -> i -> Either e (g o) evalPatternWith sel error rule interpret input = second (interpretWith rule interpret) . maybe (Left error) Right $ input ^? sel ------------------------------------------------------------------------------- -- | Build an interpreter into a functor @g@. interpretWith :: Applicative g => RuleT i e f a -> Interpret e f g -> i -> g a interpretWith (RuleT ap) int i = Ap.runAp (int i) ap ------------------------------------------------------------------------------- -- | Runs a single 'RuleF' into an applicative @g@. Passing this value to -- 'interpretWith' will fully evaluate a 'RuleT' into the same functor. type Interpret e f g = forall i a . i -> RuleF i e f a -> g a ------------------------------------------------------------------------------- -- | A 'Prosidy.Types.BlockTag' with the tag name removed. type BlockRegion = Prosidy.Region (Prosidy.Series Prosidy.Block) -- | An 'Prosidy.Types.InlineTag' with the tag name removed. type InlineRegion = Prosidy.Region (Prosidy.Series Prosidy.Inline) -- | A 'Prosidy.Types.LiteralTag' with the tag name removed. type LiteralRegion = Prosidy.Region Text