Reducer.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}

module Descript.Sugar.Data.Reducer
  ( Reducer (..)
  , PhaseCtx (..)
  , ReduceCtx (..)
  ) where

import qualified Descript.Sugar.Data.Value.In as In
import qualified Descript.Sugar.Data.Value.Out as Out
import Descript.Misc
import Data.Monoid
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 an [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 an (NonEmpty (PhaseCtx an))
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance (Monoid an) => Monoid (ReduceCtx an) where
  mempty = ReduceCtx mempty $ mempty :| []
  ReduceCtx xAnn xPhases `mappend` ReduceCtx yAnn yPhases
    = ReduceCtx (xAnn <> yAnn) (xPhases `NonEmpty.zipPadLeftM` yPhases)

instance (Monoid an) => Monoid (PhaseCtx an) where
  mempty = PhaseCtx mempty []
  PhaseCtx xAnn xrs `mappend` PhaseCtx yAnn yrs
    = PhaseCtx (xAnn <> yAnn) (xrs ++ yrs)

instance Ann ReduceCtx where
  getAnn (ReduceCtx ann _) = ann

instance Ann PhaseCtx where
  getAnn (PhaseCtx ann _) = ann

instance Ann Reducer where
  getAnn = reducerAnn

instance Printable ReduceCtx where
  aprintRec sub (ReduceCtx _ phases)
    = pintercal "\n---\n" $ map sub $ NonEmpty.toList phases

instance Printable PhaseCtx where
  aprintRec sub (PhaseCtx _ reducers) = pintercal "\n" $ map sub reducers

instance Printable Reducer where
  aprintRec sub reducer = sub (input reducer) <> ": " <> 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