DSL.hs

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