Core.hs

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