{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
module Descript.BasicInj.Data.Reducer
( Reducer (..)
, PhaseCtx (..)
, ReduceCtx (..)
) where
import qualified Descript.BasicInj.Data.Value.In as In
import qualified Descript.BasicInj.Data.Value.Out as Out
import Descript.Misc
import Data.Semigroup as S
import Data.Monoid as M
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Core.Data.List.NonEmpty as NonEmpty
-- | A reducer. It takes a value and converts it into a new value.
-- Programs are interpreted/compiled by taking values and reducing them -
-- the program starts with a value representing a question or source
-- code, and reducers convert this value into the answer or compiled code.
-- This is like a function, or even better, an implicit conversion.
data Reducer an
= Reducer
{ reducerAnn :: an
, input :: In.Value an
, output :: Out.Value an
} deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)
-- | Completely reduces a value in a particular phase.
data PhaseCtx an
= PhaseCtx
{ phaseCtxAnn :: an
, phaseCtxReducers :: [Reducer an]
} deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)
-- | Completely reduces a value. In the process, also reduces its own
-- reducers when there are reducers in higher phases.
-- Typically contains all of the reducers in a source file.
data ReduceCtx an
= ReduceCtx
{ reduceCtxAnn :: an
, reduceCtxTopPhase :: PhaseCtx an -- ^ Applied to the other phases.
, reduceCtxLowPhases :: NonEmpty (PhaseCtx an) -- ^ "Regular" phases.
} deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)
instance (Semigroup an) => Semigroup (ReduceCtx an) where
ReduceCtx xAnn xTop xLows <> ReduceCtx yAnn yTop yLows
= ReduceCtx
{ reduceCtxAnn = xAnn S.<> yAnn
, reduceCtxTopPhase = xTop S.<> yTop
, reduceCtxLowPhases = xLows `NonEmpty.zipPadS` yLows
}
instance (Monoid an) => Monoid (ReduceCtx an) where
mempty
= ReduceCtx
{ reduceCtxAnn = mempty
, reduceCtxTopPhase = mempty
, reduceCtxLowPhases = mempty :| []
}
ReduceCtx xAnn xTop xLows `mappend` ReduceCtx yAnn yTop yLows
= ReduceCtx
{ reduceCtxAnn = xAnn M.<> yAnn
, reduceCtxTopPhase = xTop M.<> yTop
, reduceCtxLowPhases = xLows `NonEmpty.zipPadM` yLows
}
instance (Semigroup an) => Semigroup (PhaseCtx an) where
PhaseCtx xAnn xrs <> PhaseCtx yAnn yrs
= PhaseCtx (xAnn S.<> yAnn) (xrs ++ yrs)
instance (Monoid an) => Monoid (PhaseCtx an) where
mempty = PhaseCtx mempty []
PhaseCtx xAnn xrs `mappend` PhaseCtx yAnn yrs
= PhaseCtx (xAnn M.<> yAnn) (xrs ++ yrs)
instance Ann ReduceCtx where
getAnn = reduceCtxAnn
instance Ann PhaseCtx where
getAnn = phaseCtxAnn
instance Ann Reducer where
getAnn = reducerAnn
instance Printable ReduceCtx where
aprintRec sub (ReduceCtx _ top lows)
-- Top phase technically isn't parsable, but this is how it would be parsed
= pimp' (sub top M.<> "\n===\n")
M.<> pintercal "\n---\n" (map sub $ NonEmpty.toList lows)
where pimp' = pimpIf $ top_ == mempty
top_ = remAnns top
instance Printable PhaseCtx where
aprintRec sub (PhaseCtx _ reducers) = pintercal "\n" $ map sub reducers
instance Printable Reducer where
aprintRec sub reducer = sub (input reducer) M.<> ": " M.<> sub (output reducer)
instance (Show an) => Summary (ReduceCtx an) where
summaryRec = pprintSummaryRec
instance (Show an) => Summary (PhaseCtx an) where
summaryRec = pprintSummaryRec
instance (Show an) => Summary (Reducer an) where
summaryRec = pprintSummaryRec