module Data.PropertyList.Types where
import Data.PropertyList.Algebra
import Control.Functor.Pointed
import Control.Functor.Fix
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Free
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(..))
import Data.Void
import Unsafe.Coerce (unsafeCoerce)
newtype PropertyList = PL { unPL :: FixF PropertyListS }
instance Eq PropertyList where
PL (InF x) == PL (InF y) = fmap PL x == fmap PL y
instance Ord PropertyList where
PL (InF x) `compare` PL (InF y) = fmap PL x `compare` fmap PL y
instance Show PropertyList where
show pl = showsPrec 0 pl " :: PropertyList"
showsPrec p (PL x) = showParen (p > 10) $ case outF x of
PLArray arr -> showString "plArray " . showsPrec 11 (fmap PL arr)
PLData bs -> showString "plData " . showsPrec 11 bs
PLDate time -> showString "plDate " . showsPrec 11 time
PLDict dict -> showString "plDict " . showsPrec 11 (fmap PL dict)
PLReal dbl -> showString "plReal " . showsPrec 11 dbl
PLInt int -> showString "plInt " . showsPrec 11 int
PLString str -> showString "plString " . showsPrec 11 str
PLBool bool -> showString "plBool " . showsPrec 11 bool
instance Copointed f => PListAlgebra f PropertyList where
plistAlgebra = PL . InF . fmap unPL . extract
instance PListCoalgebra Identity a => PListAlgebra (Either a) PropertyList where
plistAlgebra = either toPlist (plistAlgebra . Identity)
instance InitialPList Identity PropertyList
instance Pointed f => PListCoalgebra f PropertyList where
plistCoalgebra = point . fmap PL . outF . unPL
instance TerminalPList Identity PropertyList
foldPropertyList f (PL pl) = fold pl
where fold (InF x) = f (fmap fold x)
newtype PartialPropertyList a = PPL {unPPL :: Free PropertyListS a}
deriving (Pointed, Functor, Monad, MonadFree PropertyListS)
instance Applicative PartialPropertyList where
pure = return
(<*>) = ap
instance Foldable PartialPropertyList where
foldMap f (PPL x) = case runFree x of
Left x -> f x
Right x -> foldMap (foldMap f . PPL) x
instance Traversable PartialPropertyList where
traverse f (PPL x) = case runFree x of
Left x -> return <$> f x
Right x -> inFree <$> traverse (traverse f . PPL) x
instance Eq a => Eq (PartialPropertyList a) where
PPL x == PPL y = case (runFree x, runFree y) of
(Left a, Left b) -> a == b
(Right a, Right b) -> fmap PPL a == fmap PPL b
_ -> False
instance Ord a => Ord (PartialPropertyList a) where
PPL x `compare` PPL y = case (runFree x, runFree y) of
(Left a, Left b) -> a `compare` b
(Left _, Right _) -> Left () `compare` Right ()
(Right a, Right b) -> fmap PPL a `compare` fmap PPL b
(Right _, Left _) -> Right () `compare` Left ()
instance Show a => Show (PartialPropertyList a) where
showsPrec p (PPL x) = showParen (p > 10) $ case runFree x of
Left a -> showString "return " . showsPrec 11 a
Right x -> case x of
PLArray arr -> showString "plArray " . showsPrec 11 (fmap PPL arr)
PLData bs -> showString "plData " . showsPrec 11 bs
PLDate time -> showString "plDate " . showsPrec 11 time
PLDict dict -> showString "plDict " . showsPrec 11 (fmap PPL dict)
PLReal dbl -> showString "plReal " . showsPrec 11 dbl
PLInt int -> showString "plInt " . showsPrec 11 int
PLString str -> showString "plString " . showsPrec 11 str
PLBool bool -> showString "plBool " . showsPrec 11 bool
instance Copointed f => PListAlgebra f (PartialPropertyList a) where
plistAlgebra = inFree . extract
instance PListAlgebra Maybe (PartialPropertyList ()) where
plistAlgebra Nothing = return ()
plistAlgebra (Just x) = inFree x
instance PListAlgebra (Either a) (PartialPropertyList a) where
plistAlgebra (Left x) = return x
plistAlgebra (Right x) = inFree x
instance InitialPList (Either a) (PartialPropertyList a) where
instance PListCoalgebra (Either a) (PartialPropertyList a) where
plistCoalgebra (PPL xf) = fmap (fmap PPL) (runFree xf)
instance TerminalPList (Either a) (PartialPropertyList a) where
instance PListCoalgebra Maybe (PartialPropertyList a) where
plistCoalgebra (PPL xf) = case runFree xf of
Left _ -> Nothing
Right x -> Just (fmap PPL x)
completePropertyList :: PListCoalgebra Identity a => PartialPropertyList a -> PropertyList
completePropertyList = fromPlist
completePropertyListBy :: (Applicative f, PListCoalgebra Identity b)
=> (a -> f b) -> PartialPropertyList a -> f PropertyList
completePropertyListBy f = fmap completePropertyList . traverse f
completePropertyListByM :: (Monad m, PListCoalgebra Identity b)
=> (a -> m b) -> PartialPropertyList a -> m PropertyList
completePropertyListByM f = liftM completePropertyList . unwrapMonad . traverse (WrapMonad . f)
instance Functor f => PListCoalgebra f Void where
plistCoalgebra = void