In.hs

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

module Descript.BasicInj.Data.Value.In
  ( Property
  , Record
  , Part (..)
  , Value
  , OptValue (..)
  , optValToMaybeVal
  , maybeValToOptVal
  , mapOptVal
  , traverseOptVal
  , fullConsumeProp
  ) 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 Core.Data.Monoid
import Core.Data.Semigroup

-- | An input property.
type Property an = GenProperty OptValue an

-- | An input record.
type Record an = GenRecord OptValue an

-- | An input part.
data Part an
  = PartPrim (Prim an)
  | PartPrimType (PrimType an)
  | PartRecord (Record an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

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

-- | Either nothing or a value. Composition of 'Maybe' and 'Value'.
data OptValue an
  = NothingValue
  | JustValue (Value an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance (Semigroup an, Monoid an) => Monoid (OptValue an) where
  mempty = JustValue mempty
  NothingValue `mappend` _ = NothingValue
  JustValue _ `mappend` NothingValue = NothingValue
  JustValue x `mappend` JustValue y = JustValue $ x M.<> y

instance (Semigroup an) => Semigroup (OptValue an) where
  NothingValue <> _ = NothingValue
  JustValue _ <> NothingValue = NothingValue
  JustValue x <> JustValue y = JustValue $ x S.<> y

instance GenPropVal OptValue where
  doesPrint NothingValue = False
  doesPrint (JustValue _) = True

instance Monoid1 OptValue

instance Semigroup1 OptValue

instance GenPart Part where
  type PartPropVal Part = OptValue

  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 (PartPrimType typ) parts = PartPrimType typ : parts
  mergeAddPart (PartRecord record) parts = mergeAddRecord record parts

instance Ann Part where
  getAnn (PartPrim x) = getAnn x
  getAnn (PartPrimType x) = getAnn x
  getAnn (PartRecord x) = getAnn x

instance FwdPrintable OptValue where
  afprintRec _ NothingValue = mempty
  afprintRec sub (JustValue x) = sub x

instance Printable Part where
  aprintRec sub (PartPrim prim) = sub prim
  aprintRec sub (PartPrimType primType) = sub primType
  aprintRec sub (PartRecord record) = aprintRec sub record

instance (Show an) => Summary (OptValue an) where
  summaryRec sub = pprintSummaryRecF sub

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

-- | Converts the 'OptValue' to an equivalent maybe value.
optValToMaybeVal :: OptValue an -> Maybe (Value an)
optValToMaybeVal NothingValue = Nothing
optValToMaybeVal (JustValue val) = Just val

-- | Converts the maybe value to an equivalent 'OptValue'.
maybeValToOptVal :: Maybe (Value an) -> OptValue an
maybeValToOptVal Nothing = NothingValue
maybeValToOptVal (Just val) = JustValue val

-- | Transform the value.
mapOptVal :: (Value an1 -> Value an2) -> OptValue an1 -> OptValue an2
mapOptVal _ NothingValue = NothingValue
mapOptVal f (JustValue x) = JustValue $ f x

-- | Transform the value with side effects if it exists.
traverseOptVal :: (Applicative w)
               => (Value an1 -> w (Value an2))
               -> OptValue an1
               -> w (OptValue an2)
traverseOptVal _ NothingValue = pure NothingValue
traverseOptVal f (JustValue x) = JustValue <$> f x

-- | A property with the given key and 'NothingValue' (consumes all
-- input) as its value.
fullConsumeProp :: Symbol an -> Property an
fullConsumeProp key = Property ann key NothingValue
  where ann = getAnn key