Reducer.hs

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