Run.hs

{-|
Module      : Prosidy.Compile.Run
Description : Interpretation of compilation rules.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Prosidy.Compile.Run (run, runM) where

import           Lens.Micro
import           Prosidy.Compile.Core
import           Prosidy.Compile.Error

import           Data.Bifunctor                 ( Bifunctor(..) )
import           Data.Functor.Identity          ( Identity(..) )

import qualified Prosidy                       as P

-------------------------------------------------------------------------------
-- | Run a 'Rule' against an input, returning a parse result.
run :: IsError e => RuleT i e Identity a -> i -> Either (ErrorSet e) a
run rule = runIdentity . runM rule

-- | Run a 'RuleT' against an input, returning a contextual parse result.
runM
    :: (Applicative context, IsError e)
    => RuleT i e context a
    -> i
    -> context (Either (ErrorSet e) a)
runM rule = (\(Run x) -> x) . runRun rule

-------------------------------------------------------------------------------
newtype Run error context output = Run
    (context (Either (ErrorSet error) output))
  deriving Functor

instance (Applicative context, IsError error) => Applicative (Run error context) where
    pure = Run . pure . Right
    {-# INLINE pure #-}

    Run lhsF <*> Run rhsF = Run $ do
        lhs <- lhsF
        rhs <- rhsF
        pure $ either (\es -> Left $ either (es <>) (const es) rhs)
                      (\fn -> second fn rhs)
                      lhs

instance (Applicative context, IsError error) => ApError (ErrorSet error) (Run error context) where
    liftError = Run . pure . Left
    {-# INLINE liftError #-}

    mapError f (Run r) = Run $ fmap (first f) r

runRun
    :: (Applicative context, IsError e)
    => RuleT i e context a
    -> i
    -> Run e context a
runRun rule = interpretWith rule interpret

interpret
    :: (Applicative context, IsError error)
    => Interpret error context (Run error context)
interpret input = \case
    Fail e      -> liftError1 e
    Lift lifted -> Run . fmap (first singleError) $ lifted input
    TestMatch matches ->
        groupErrors input $ evalPatterns matches interpret input
    Traverse f g rule -> do
        fmap g . traverse (runRun rule) $ f input
    GetContent rule   -> runRun rule $ input ^. P.content
    GetProperty k key -> input ^. P.hasProperty key & pure . k
    GetSetting k key parse ->
        input ^. P.atSetting key & traverse parse & either
            (liftError1 . ParseError key)
            (pure . k)
    GetRequiredSetting key parse -> do
        input ^. P.atSetting key & maybe
            (liftError1 $ Required key)
            (either (liftError1 . ParseError key) pure . parse)
    GetSelf k -> pure $ k input