Rules.hs

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