Out.hs

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

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

import Descript.BasicInj.Data.Value.Gen
import Descript.BasicInj.Data.Atom
import Descript.Misc
import Data.Semigroup as S
import Data.Monoid as M
import Data.String

-- | 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 (Semigroup an, Monoid an) => Monoid (InjParam an) where
  mempty
    = InjParam
    { injParamAnn = mempty
    , injParamVal = mempty
    }

  InjParam xAnn xVal `mappend` InjParam yAnn yVal
    = InjParam
    { injParamAnn = xAnn M.<> yAnn
    , injParamVal = xVal M.<> yVal
    }

instance (Semigroup an) => Semigroup (InjParam an) where
  InjParam xAnn xVal <> InjParam yAnn yVal
    = InjParam
    { injParamAnn = xAnn S.<> yAnn
    , injParamVal = xVal S.<> yVal
    }

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

  mergeAddPart (PartPrim prim) parts = PartPrim prim : parts
  mergeAddPart (PartRecord record) parts = mergeAddRecord record parts
  mergeAddPart (PartPropPath path) parts = PartPropPath path : parts
  mergeAddPart (PartInjApp app) parts = mergeAddInjApp app parts

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) M.<> paramsPrinted
    where paramsPrinted = "[" M.<> pintercal ", " paramPrinteds M.<> "]"
          paramPrinteds = zipWith (paramPrint sub) idxPropKeys $ params app

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

instance (Show an) => Summary (InjApp 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

mergeAddInjApp :: (Semigroup an) => InjApp an -> [Part an] -> [Part an]
mergeAddInjApp app [] = [PartInjApp app]
mergeAddInjApp app (x : xs)
  = case tryMergeInjAppWithPart app x of
         Failure () -> x : mergeAddInjApp app xs
         Success newApp -> PartInjApp newApp : xs

tryMergeInjAppWithPart :: (Semigroup an)
                       => InjApp an
                       -> Part an
                       -> UResult (InjApp an)
tryMergeInjAppWithPart xApp (PartInjApp yApp) = tryMergeInjApps xApp yApp
tryMergeInjAppWithPart _ _ = Failure ()

tryMergeInjApps :: (Semigroup an)
                => InjApp an
                -> InjApp an
                -> UResult (InjApp an)
tryMergeInjApps (InjApp xAnn xFuncId xParams) (InjApp yAnn yFuncId yParams)
  | xFuncId /@= yFuncId = Failure ()
  | otherwise = Success InjApp
  { injAppAnn = xAnn S.<> yAnn
  , funcId = xFuncId `eappend` yFuncId
  , params = zipWith (S.<>) xParams yParams
  }

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

-- | A property with the given key and a path to itself (with the given
-- record head) as its value.
fullProduceProp :: FSymbol () -> Symbol () -> Property ()
fullProduceProp head' key = Property () key val
  where val = immPathVal $ PathElem () key head'


paramPrint :: (Monoid r, IsString r)
           => (Value an -> r)
           -> Symbol ()
           -> InjParam an
           -> r
paramPrint sub label (InjParam _ val)
     = fromString (pprintStr label)
  M.<> ": "
  M.<> sub val