Run.hs

{-|
Module      : Prosidy.Compile.Run
Description : A basic intepreter for 'Prosidy.Compile.Core.Rules'.
Copyrighr   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Prosidy.Compile.Run (RunError(..), RunErrors(..), RunT, Run, run, runT) where

import           Lens.Micro

import qualified Prosidy                       as P
import qualified Prosidy.Source                as PS
import           Prosidy.Types.Series           ( pattern Empty
                                                , pattern (:<:)
                                                , pattern (:<<:)
                                                )

import Control.Exception (Exception(..))
import           Prosidy.Compile.Core
import           Data.Function                  ( on )
import           Data.Functor.Identity          ( Identity(..) )
import           Data.Bifunctor                 ( Bifunctor(..) )
import           Data.Profunctor                ( Profunctor(..)
                                                , Strong(..)
                                                )
import Data.Either.Valid (Valid(..))
import qualified Data.Either.Valid as Valid
import           Data.Text                      ( Text )
import Control.Monad (unless)
import Data.Set (Set)
import Data.Foldable (toList, foldl')
import qualified Data.HashMap.Strict as HM
import Data.Semigroup (Semigroup(..))

import Data.Text.Prettyprint.Doc (Pretty(..), (<+>))
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.String as PPS

import qualified Data.HashSet as HashSet
import qualified Data.Set                      as Set
import qualified Data.Text as Text

-- | 'RunT' specialized to 'Identity'.
type Run = RunT Identity

-- | An interpreter over 'Rules'.
newtype RunT f t a = RunT
  { _run :: t -> Observe -> Valid RunErrors (f a, Observe) }
--   deriving (Functor, Applicative) via Compose ((->) t) (Compose (Result RunError) _)

instance Functor f => Functor (RunT f t) where
    fmap = rmap

instance Applicative f => Applicative (RunT f t) where
    pure x = RunT $ \_ o -> pure (pure x, o)

    RunT lhs <*> RunT rhs = RunT $ \t obs ->
      let
        combine ~(f, o1) ~(x, o2) = (f <*> x, o1 <> o2)
      in
        combine <$> lhs t obs <*> rhs t obs

instance Applicative f => Alternative (RunT f t) where
    empty = RunT $ \_ _ -> empty

    RunT lhs <|> RunT rhs = RunT $ \t obs ->
        lhs t obs <|> rhs t obs 

instance Functor f => Profunctor (RunT f) where
    dimap f g = RunT . go . _run
      where
        go r t obs = first (fmap g) <$> r (f t) obs

instance Functor f => Strong (RunT f) where
    first' = RunT . go . _run
      where
        go r (t, c) obs = first (fmap (, c)) <$> r t obs
    second' = RunT . go . _run
      where
        go r (c, t) obs = first (fmap (c ,)) <$> r t obs

-- | Run a 'Run' interpreter to completion.
run :: i -> Run i a -> Either RunErrors a
run = (fmap runIdentity .) . runT

-- | Run a 'RunT' interpreter to completion.
runT :: i -> RunT f i a -> Either RunErrors (f a)
runT i = fmap fst . Valid.toEither . (\r -> _run r i mempty)

runWith :: (t -> Valid RunErrors (f a)) -> RunT f t a
runWith f = RunT $ \t obs -> (, obs) <$> f t

-- | Errors that may be returned from the interpreter.
data RunError =
    Group Location (Set RunError)
    -- ^ Groups a set of errors with a location for more helpful error 
    -- messages.
  | MatchError Text
    -- ^ Expected a different type. Thrown on failed matches of sum types.
  | ParseError P.Key String
    -- ^ The provided parser failed to parse a setting.
  | RequiredSetting P.Key
    -- ^ A setting was required, but not found on a node.
  | TooFewElements
    -- ^ Expected more elements when matching sequentially.
  | TooManyElements
    -- ^ Expected fewer elements when matching sequentially.
  | UnexpectedProperties (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
    -- ^ A property was found on a node, but not mentioned in its specification.
  | UnexpectedSettings (HashSet.HashSet P.Key) (HashSet.HashSet P.Key)
    -- ^ A setting was found on a node, but not mentioned in its specification.
  deriving (Show, Eq, Ord)

instance Exception RunError where
    displayException = prettyString

instance Pretty RunError where
    pretty (Group loc errors) = PP.nest 4 $ PP.vsep
        [ "Encountered" <+> errorNoun <+> "in" <+> pretty loc
        , pretty (RunErrors errors)
        ] 
      where
        errorCount = length errors
        errorNoun 
          | errorCount == 1 = "an error"
          | otherwise       = pretty errorCount <+> "errors"

    pretty (MatchError desc) =
        "Expected" <+> pretty desc

    pretty (ParseError key msg) =
        "Failed to parse setting" <+> pretty key <> ":" <+> pretty msg

    pretty (RequiredSetting key) =
        "Node is missing the required setting" <+> pretty key

    pretty TooFewElements =
        "Expected one or more additional nodes within the current context."

    pretty TooManyElements =
        "Expected no further elements in the current context."

    pretty (UnexpectedProperties allowed got) = PP.nest 4 $ PP.vsep 
        [ "Encountered at least one unexpected property on the current node."
        , "Allowed properties:   " <+> pretty (toList allowed)
        , "Unexpected properties:" <+> pretty (toList got)
        ]

    pretty (UnexpectedSettings allowed got) = PP.nest 4 $ PP.vsep 
        [ "Encountered at least one unexpected setting on the current node."
        , "Allowed settings:   " <+> pretty (toList allowed)
        , "Unexpected settings:" <+> pretty (toList got)
        ]

-- | A newtype wrapper over a set of 'RunError's. 
--
-- This is defined to allow an instances of 'Exception' and 'Pretty' for error
-- sets.
newtype RunErrors = RunErrors (Set RunError)
  deriving (Show, Eq, Ord)

instance Exception RunErrors where
    displayException = prettyString

instance Semigroup RunErrors where
    lhs@(RunErrors lset) <> rhs@(RunErrors rset) 
      | null lset = rhs
      | null rset = lhs
      | otherwise = RunErrors $ combineErrors [lhs, rhs]
    sconcat = RunErrors . combineErrors

instance Monoid RunErrors where
    mempty = RunErrors mempty
    mconcat = RunErrors . combineErrors

instance Pretty RunErrors where
    pretty = \(RunErrors es) -> 
        mconcat (zipWith combine delims (toList es)) <> PP.rbracket
      where
        delims = PP.lbracket : repeat PP.comma
        combine delim item =
            delim <> PP.flatAlt " " mempty <> pretty item <> PP.line'

runErrors :: RunErrors -> Set RunError
runErrors = \(RunErrors es) -> es

failure :: RunError -> Valid RunErrors a
failure = Invalid . RunErrors . Set.singleton

groupErrors :: P.HasLocation t => RunT f t a -> RunT f t a
groupErrors (RunT f) = RunT $ \i o ->
    case f i o of
        Invalid errors@(RunErrors errorSet)
          | shouldWrap errors 
          , Just loc <- i ^? P.location
          -> Invalid . RunErrors . Set.singleton $ Group (Location loc) errorSet
        other -> other

shouldWrap :: RunErrors -> Bool
shouldWrap (RunErrors es) 
  | count >= 2 = True
  | otherwise  = any (\case Group{} -> False; _ -> True) es
  where count = length es

combineErrors :: Foldable f => f RunErrors -> Set RunError
combineErrors =
      HM.foldlWithKey' go mempty 
    . groupGroups 
    . foldMap runErrors
  where
    go acc key val = Set.union acc $ case key of
        Just loc -> Set.singleton (Group (Location loc) val)
        Nothing  -> val

groupGroups :: Foldable f => f RunError -> HM.HashMap (Maybe P.Location) (Set RunError)
groupGroups = foldl' 
    (\acc -> \case
        Group (Location loc) e -> HM.insertWith (<>) (Just loc) e acc
        other -> HM.insertWith (<>) Nothing (Set.singleton other) acc)
    mempty
    
newtype Location = Location P.Location
  deriving (Show, Eq)

instance Pretty Location where
    pretty (Location l) = pretty l

instance Ord Location where
    compare = compare `on` \(Location loc) ->
        (PS.sourceName (PS.locationSource loc), PS.locationOffset loc)

-------------------------------------------------------------------------------
instance Applicative f => Context (RunT f) where
    type Local (RunT f) = f

    runSelf  = RunT $ \t obs -> pure (pure t, obs)
    liftRule r = RunT $ \_ obs -> pure (r, obs)

instance Applicative f => Interpret (RunT f) P.Block where
    runRule = groupErrors . \case
        BlockRuleBlockTag nested -> RunT $ \block obs -> case block of
            P.BlockTag tag -> _run (pedantic $ interpret nested) tag mempty
            _              -> (, obs) <$> expected "BlockTag"

        BlockRuleLiteralTag nested -> RunT $ \block obs -> case block of
            P.BlockLiteral tag -> _run (pedantic $ interpret nested) tag mempty
            _                  -> (, obs) <$> expected "BlockLiteral"

        BlockRuleParagraph nested -> RunT $ \block obs -> case block of
            P.BlockParagraph pg -> _run (interpret nested) pg mempty
            _                   -> (, obs) <$> expected "BlockParagraph"

instance Applicative f => Interpret (RunT f) P.Document where
    runRule (DocumentRule regionRule) =
        RunT $ _run (runRule regionRule) . P.documentToRegion

instance Applicative f => Interpret (RunT f) P.Fragment where
    runRule = \case
        FragmentRuleLocation callback -> 
            runWith $ pure . pure . callback . P.fragmentLocation

        FragmentRuleText callback -> 
            runWith $ pure . pure . callback . P.fragmentText

instance Applicative f => Interpret (RunT f) P.Inline where
    runRule = \case
        InlineRuleBreak item -> runWith $ \inline -> case inline of
            P.Break -> pure $ pure item
            _       -> expected "Break"

        InlineRuleInlineTag nested -> RunT $ \inline obs -> case inline of
            P.InlineTag tag -> _run (pedantic $ interpret nested) tag mempty
            _               -> (, obs) <$> expected "InlineTag"

        InlineRuleFragment nested -> RunT $ \inline obs -> case inline of
            P.InlineText fragment -> _run (interpret nested) fragment mempty
            _                     -> (, obs) <$> expected "InlineText"

instance Applicative f => Interpret (RunT f) P.Metadata where
    runRule = \case
        MetadataRuleProperty callback key ->
            observeProperty key *>
            runWith (pure . pure . callback . (^. P.hasProperty key))

        MetadataRuleSetting parse def key -> 
            observeSetting key *>
            runWith (\metadata ->
                case metadata ^. P.atSetting key of
                    Nothing -> maybe (failure $ RequiredSetting key) (pure . pure) def
                    Just raw ->
                        Valid.fromEither
                            . bimap (RunErrors . Set.singleton . ParseError key) pure
                            $ parse raw)

        MetadataRuleAllowUnknown x -> RunT $ \_ _ ->
            pure (pure x, NoObserve)

instance Applicative f => Interpret (RunT f) P.Paragraph where
    runRule = \case
        ParagraphRuleContent nested ->
            RunT $ _run (interpret nested) . P.paragraphContent

        ParagraphRuleLocation callback ->
            runWith $ pure . pure . callback . P.paragraphLocation

instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Region t) where
    runRule = \case
        RegionRuleContent nested -> RunT $ \t obs ->
            second (const obs)
            <$> _run (interpret nested) (P.regionContent t) mempty

        RegionRuleLocation callback ->
            runWith $ Valid.Valid . pure @f . callback . P.regionLocation

        RegionRuleMetadata rule ->
            RunT $ _run (runRule rule) . P.regionMetadata

instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Tag t) where
    runRule = \case
        TagRuleKey key ret ->
            runWith
                $ \tag -> if P.tagName tag == key
                      then pure $ pure ret
                      else failure . MatchError $ "rawKey == " <> Text.pack (show $ P.rawKey key)

        TagRuleRegion nested -> RunT $ _run (runRule nested) . P.tagToRegion

instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.Series t) where
    runRule = \case
        SeriesRuleNext rule -> RunT $ \series -> case series of
            x :<: xs -> _run (runRule rule) (x :<<: xs)
            Empty    -> const $ failure TooFewElements

        SeriesRuleEmpty ret -> runWith $ \series -> case series of
            _ :<: _ -> failure TooManyElements
            Empty   -> pure $ pure ret

instance (Applicative f, Interpret (RunT f) t) => Interpret (RunT f) (P.SeriesNE t) where
    runRule (SeriesNERule combine rule rules) = RunT $ \(x :<<: xs) o ->
        (\(f1, o1) (f2, o2) -> (combine <$> f1 <*> f2, o1 <> o2))
            <$> _run (interpret rule) x o
            <*> _run (interpret rules) xs o

instance Applicative f => Interpret (RunT f) Text

expected :: Text -> Valid RunErrors a
expected = failure . MatchError

-------------------------------------------------------------------------------
data Observe = 
    NoObserve
  | Observe !Observing
  deriving Show

instance Semigroup Observe where
    Observe lhs <> Observe rhs = Observe (lhs <> rhs)
    NoObserve <> _ = NoObserve
    _ <> NoObserve = NoObserve

instance Monoid Observe where
    mempty = NoObserve

data Observing = Observing
  { obsProperties :: !(HashSet.HashSet P.Key)
  , obsSettings :: !(HashSet.HashSet P.Key)
  }
  deriving Show

instance Semigroup Observing where
    Observing a b <> Observing z y = Observing (a <> z) (b <> y)

instance Monoid Observing where
    mempty = Observing mempty mempty

observeProperty :: Applicative f => P.Key -> RunT f t ()
observeProperty k = RunT $ \_ o -> 
  let
    o' = case o of
        Observe obs -> Observe $ obs 
            { obsProperties = HashSet.insert k $ obsProperties obs }
        NoObserve -> o
  in
    pure (pure (), o')

observeSetting :: Applicative f => P.Key -> RunT f t ()
observeSetting k = RunT $ \_ o -> 
  let
    o' = case o of
        Observe obs -> Observe $ obs 
            { obsSettings = HashSet.insert k $ obsSettings obs }
        NoObserve -> o
  in
    pure (pure (), o')

pedantic :: P.HasMetadata t => RunT f t a -> RunT f t a
pedantic = RunT . go . _run
  where
    check t = \case
        Observe (Observing props settings) -> do
            let unexpectedProps = t ^.. P.properties . folded . filtered (not . flip HashSet.member props)
                unexpectedSettings = t ^.. P.settings . P._Assoc . to HM.keys . folded . filtered (not . flip HashSet.member settings)
            unless (null unexpectedProps) $
                failure (UnexpectedProperties props (HashSet.fromList unexpectedProps))
            unless (null unexpectedSettings) $
                failure (UnexpectedSettings settings (HashSet.fromList unexpectedSettings))
            pure ()

        NoObserve -> 
            pure ()

    go f t obs = 
      let
        result = f t $ case obs of
            NoObserve -> Observe mempty
            _         -> obs
      in
        result <* case result of
            Valid.Valid (_, o) -> check t o
            _ -> pure ()

-------------------------------------------------------------------------------
prettyString :: Pretty a => a -> String
prettyString = 
    PPS.renderString
        . PP.layoutPretty (PP.defaultLayoutOptions { PP.layoutPageWidth = PP.Unbounded }) 
        . pretty