Out.hs

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

module Descript.Sugar.Data.Value.Out
  ( Property
  , Record
  , InjParam (..)
  , InjApp (..)
  , Part (..)
  , Value
  , immPathVal
  , mapInjAppParams
  , mapInjParamVal
  , traverseInjParamVal
  , idxPropKeys
  ) where

import Descript.Sugar.Data.Value.Gen
import Descript.Sugar.Data.Atom
import Descript.Misc
import Data.Monoid

-- | An output property.
type Property an = GenProperty (GenValue Part) an

-- | An output record.
type Record an = GenRecord (GenValue Part) an

-- | A parameter of an injected function.
data InjParam an
  = InjParam
  { injParamAnn :: an
  , injParamVal :: Value an
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | An application of an injected function.
data InjApp an
  = InjApp
  { injAppAnn :: an
  , funcId :: InjSymbol an
  , params :: [InjParam an]
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | An output part.
data Part an
  = PartPrim (Prim an)
  | PartRecord (Record an)
  | PartPropPath (PropPath an)
  | PartInjApp (InjApp an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | An output value.
type Value an = GenValue Part an

instance GenPart Part where
  type PartPropVal Part = GenValue Part

  partToPrim (PartPrim prim) = Just prim
  partToPrim _ = Nothing

  partToRec (PartRecord record) = Just record
  partToRec _ = Nothing

  primToPart _ = PartPrim
  recToPart _ = PartRecord

instance Ann Part where
  getAnn (PartPrim x) = getAnn x
  getAnn (PartRecord x) = getAnn x
  getAnn (PartPropPath x) = getAnn x
  getAnn (PartInjApp x) = getAnn x

instance Ann InjApp where
  getAnn = injAppAnn

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

instance Printable Part where
  aprintRec sub (PartPrim prim) = sub prim
  aprintRec sub (PartRecord record) = sub record
  aprintRec sub (PartPropPath path) = sub path
  aprintRec sub (PartInjApp app) = sub app

instance Printable InjApp where
  aprintRec sub app = sub (funcId app) <> paramsPrinted
    where paramsPrinted = "[" <> pintercal ", " paramPrinteds <> "]"
          paramPrinteds = map sub $ params app

instance Printable InjParam where
  aprintRec sub (InjParam _ val) = sub val

instance (Show an) => Summary (Part an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (InjApp an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (InjParam an) where
  summaryRec = pprintSummaryRec

-- | Refers to the immediate property corresponding to the path element.
immPathVal :: PathElem () -> Value ()
immPathVal = singletonValue . PartPropPath . immPath

mapInjAppParams :: (InjParam an -> InjParam an) -> InjApp an -> InjApp an
mapInjAppParams f (InjApp ann funcId' params')
  = InjApp ann funcId' $ map f params'

-- | Transforms the value in the injected parameter.
mapInjParamVal :: (Value an -> Value an) -> InjParam an -> InjParam an
mapInjParamVal f (InjParam ann x) = InjParam ann $ f x

-- | Transforms the value in the injected parameter with side effects.
traverseInjParamVal :: (Functor w)
                    => (Value an -> w (Value an))
                    -> InjParam an
                    -> w (InjParam an)
traverseInjParamVal f (InjParam ann x) = InjParam ann <$> f x

-- | Each of these keys in an injected function application corresponds
-- to a parameter at its position.
idxPropKeys :: [Symbol ()]
idxPropKeys = map (Symbol () . pure) ['a'..'z']