Gen.hs

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

module Descript.Sugar.Data.Value.Gen
  ( GenProperty (..)
  , GenRecord (..)
  , GenValue (..)
  , PartProperty
  , PartRecord
  , GenPropVal (..)
  , GenPart (..)
  , singletonValue
  , isEmpty
  , primParts
  , mapParts
  , foldMapParts
  , traverseParts
  , recWithHead
  , forceRecWithHead
  , deleteRecWithHead
  , partHasHead
  , recHasHead
  , mapPropVals
  , foldMapPropVals
  , traversePropVals
  ) where

import Prelude hiding (head)
import Descript.Sugar.Data.Atom
import Descript.Misc
import Data.Monoid
import Data.Proxy
import Data.Maybe
import Data.List hiding (head)

-- | A property whose values are of type @v@.
data GenProperty v an
  = Property
  { propertyAnn :: an
  , propertyKey :: Maybe (Symbol an)
  , propertyValue :: v an
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A record whose property values are of type @v@ - a record in a
-- value of type @v@.
--
-- Records are the main data of Descript. A record with no properties
-- encodes a singleton value or leaf. A record with properties encodes a
-- structure, or a tree where the properties are branches. Records are
-- similar to products, but their fields are named and they can be
-- differentiated by thier heads.
data GenRecord v an
  = Record
  { recordAnn :: an
  , head :: Symbol an
  , properties :: [GenProperty v an]
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A value whose parts are of type 'p'.
data GenValue p an
  = Value
  { valueAnn :: an
  , valueParts :: [p an]
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A property for a particular part.
type PartProperty p an = GenProperty (PartPropVal p) an

-- | A record for a particular part.
type PartRecord p an = GenRecord (PartPropVal p) an

class GenPropVal v where
  -- | Whether this prints in a property definition.
  -- If true, it would print @key: ...@. If false, it would print @key@.
  doesPrint :: v an -> Bool

-- | A part of a value.
class (Ann p, GenPropVal (PartPropVal p), Eq (p ())) => GenPart p where
  type PartPropVal p :: * -> *

  partToPrim :: p an -> Maybe (Prim an)
  partToRec :: p an -> Maybe (PartRecord p an)
  primToPart :: Proxy p -> Prim an -> p an
  recToPart :: Proxy p -> PartRecord p an -> p an

instance (GenPart p) => GenPropVal (GenValue p) where
  doesPrint _ = True

instance (Functor p, Foldable p, Traversable p) => SAnn (GenValue p) where
  mapSAnn f (Value ann parts) = Value (f ann) parts

instance (Functor p, Foldable p, Traversable p) => Ann (GenValue p) where
  getAnn = valueAnn

instance (Functor v, Foldable v, Traversable v) => Ann (GenRecord v) where
  getAnn = recordAnn

instance (Functor v, Foldable v, Traversable v) => Ann (GenProperty v) where
  getAnn = propertyAnn

instance (Printable p) => Printable (GenValue p) where
  aprintRec sub (Value _ parts) = pintercal " | " $ map sub parts

instance (Printable p) => FwdPrintable (GenValue p) where
  afprintRec = id

instance (FwdPrintable v, GenPropVal v) => Printable (GenRecord v) where
  aprintRec sub record = sub (head record) <> propsPrinted
    where propsPrinted = "[" <> pintercal ", " propPrinteds <> "]"
          propPrinteds = map sub $ properties record

instance (FwdPrintable v, GenPropVal v) => Printable (GenProperty v) where
  aprintRec sub (Property _ key val)
    = case key of
           Nothing -> valPrinted
           Just key'
            | doesPrint val -> keyPrinted <> ": " <> valPrinted
            | otherwise -> keyPrinted
            where keyPrinted = sub key'
    where valPrinted = afprintRec sub val

instance (Show an, Printable p, Show (p an)) => Summary (GenValue p an) where
  summaryRec = pprintSummaryRec

instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenRecord v an) where
  summaryRec = pprintSummaryRec

instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenProperty v an) where
  summaryRec = pprintSummaryRec

-- | Creates a value with just the given part.
singletonValue :: (Ann p) => p an -> GenValue p an
singletonValue part = Value (getAnn part) [part]

-- | Whether the value has any parts.
isEmpty :: GenValue p an -> Bool
isEmpty (Value _ parts) = null parts

-- | All primitives in the value.
primParts :: (GenPart p) => GenValue p an -> [Prim an]
primParts = mapMaybe partToPrim . valueParts

-- | Maps the parts.
mapParts :: (p1 an -> p2 an) -> GenValue p1 an -> GenValue p2 an
mapParts f (Value ann parts) = Value ann $ map f parts

-- | Maps then folds the parts.
foldMapParts :: (Monoid r) => (p an -> r) -> GenValue p an -> r
foldMapParts f (Value _ parts) = foldMap f parts

-- | Traverses the parts.
traverseParts :: (Applicative w)
              => (p1 an -> w (p2 an))
              -> GenValue p1 an
              -> w (GenValue p2 an)
traverseParts f (Value ann parts) = Value ann <$> traverse f parts

-- | Gets the record in the value with the given head.
recWithHead :: (GenPart p)
            => Symbol an1
            -> GenValue p an2
            -> Maybe (PartRecord p an2)
recWithHead head' (Value _ parts)
  = find (recHasHead head') $ mapMaybe partToRec parts

-- | Gets the record in the value with the given head.
-- Returns an error if the value isn't present
forceRecWithHead :: (GenPart p)
                 => Symbol an1
                 -> GenValue p an2
                 -> PartRecord p an2
forceRecWithHead head' value
  = case recWithHead head' value of
         Nothing -> error "Value doesn't contain record with head"
         Just record -> record

-- | Removes the record in the value with the given head.
-- If this record doesn't exist, does nothing.
deleteRecWithHead :: (GenPart p)
                  => Symbol an
                  -> GenValue p an
                  -> GenValue p an
deleteRecWithHead head' (Value ann parts)
  = Value ann $ filter (partHasHead head') parts

-- | Whether the part's a record with the given head.
partHasHead :: (GenPart p) => Symbol an -> p an -> Bool
partHasHead head' part
  = case partToRec part of
         Just record -> recHasHead head' record
         Nothing -> False

-- | Does the record have the given head?
recHasHead :: Symbol an1 -> GenRecord v an2 -> Bool
recHasHead head' record = remAnns head' == remAnns (head record)

-- | Maps the record's property values.
mapPropVals :: (v an -> v2 an) -> GenRecord v an -> GenRecord v2 an
mapPropVals f record
  = Record
  { recordAnn = recordAnn record
  , head = head record
  , properties = map (mapPropVal f) $ properties record
  }

-- | Maps then folds the record's property values.
foldMapPropVals :: (Monoid r) => (v an -> r) -> GenRecord v an -> r
foldMapPropVals f = foldMap (f . propertyValue) . properties

-- | Traverses the record's property values.
traversePropVals :: (Applicative w) => (v an -> w (v2 an)) -> GenRecord v an -> w (GenRecord v2 an)
traversePropVals f record
    = Record (recordAnn record) (head record)
  <$> traverse (traversePropVal f) (properties record)

mapPropVal :: (v an -> v2 an) -> GenProperty v an -> GenProperty v2 an
mapPropVal f (Property ann key val) = Property ann key $ f val

traversePropVal :: (Applicative w) => (v an -> w (v2 an)) -> GenProperty v an -> w (GenProperty v2 an)
traversePropVal f (Property ann key val) = Property ann key <$> f val