module Data.PVar.Structure (Structure (..), writeSoleCon, Value (..), MaybeC (..), EitherC (..), ListC (..)) where
import Control.Applicative ((<$>))
import Control.Arrow ((***), first)
import Data.PVar
class Structure a where
type Constructor a
data PStructure a
type Inner a
newStruc :: IO (PStructure a, a)
writeStruc :: PStructure a -> Constructor a -> IO (Inner a)
writeSoleCon :: (Structure a, Constructor a ~ ()) => PStructure a -> IO (Inner a)
writeSoleCon = flip writeStruc ()
newtype Value a = Value { getValue :: a }
instance Structure (Value a) where
type Constructor (Value a) = a
newtype PStructure (Value a) = PValue (PVar a)
type Inner (Value a) = ()
newStruc = (PValue *** Value) <$> newPVar
writeStruc (PValue pv) = writePVar pv
instance Structure () where
type Constructor () = ()
newtype PStructure () = Unit (PVar ())
type Inner () = ()
newStruc = first Unit <$> newPVar
writeStruc (Unit pv) = writePVar pv
instance (Structure a, Structure b) => Structure (a, b) where
type Constructor (a, b) = ()
newtype PStructure (a, b) = PPair (PVar (a, b))
type Inner (a, b) = (PStructure a, PStructure b)
newStruc = first PPair <$> newPVar
writeStruc (PPair pv) _ = do (pa, a) <- newStruc
(pb, b) <- newStruc
writePVar pv (a, b)
return (pa, pb)
instance (Structure a, Structure b, Structure c) => Structure (a, b, c) where
type Constructor (a, b, c) = ()
newtype PStructure (a, b, c) = Tuple3 (PVar (a, b, c))
type Inner (a, b, c) = (PStructure a, PStructure b, PStructure c)
newStruc = first Tuple3 <$> newPVar
writeStruc (Tuple3 pv) _ = do (pa, a) <- newStruc
(pb, b) <- newStruc
(pc, c) <- newStruc
writePVar pv (a, b, c)
return (pa, pb, pc)
instance (Structure a, Structure b, Structure c, Structure d) => Structure (a, b, c, d) where
type Constructor (a, b, c, d) = ()
newtype PStructure (a, b, c, d) = Tuple4 (PVar (a, b, c, d))
type Inner (a, b, c, d) = (PStructure a, PStructure b, PStructure c, PStructure d)
newStruc = first Tuple4 <$> newPVar
writeStruc (Tuple4 pv) _ = do (pa, a) <- newStruc
(pb, b) <- newStruc
(pc, c) <- newStruc
(pd, d) <- newStruc
writePVar pv (a, b, c, d)
return (pa, pb, pc, pd)
instance (Structure a, Structure b, Structure c, Structure d, Structure e) => Structure (a, b, c, d, e) where
type Constructor (a, b, c, d, e) = ()
newtype PStructure (a, b, c, d, e) = Tuple5 (PVar (a, b, c, d, e))
type Inner (a, b, c, d, e) = (PStructure a, PStructure b, PStructure c, PStructure d, PStructure e)
newStruc = first Tuple5 <$> newPVar
writeStruc (Tuple5 pv) _ = do (pa, a) <- newStruc
(pb, b) <- newStruc
(pc, c) <- newStruc
(pd, d) <- newStruc
(pe, e) <- newStruc
writePVar pv (a, b, c, d, e)
return (pa, pb, pc, pd, pe)
instance (Structure a, Structure b, Structure c, Structure d, Structure e, Structure f) => Structure (a, b, c, d, e, f) where
type Constructor (a, b, c, d, e, f) = ()
newtype PStructure (a, b, c, d, e, f) = Tuple6 (PVar (a, b, c, d, e, f))
type Inner (a, b, c, d, e, f) = (PStructure a, PStructure b, PStructure c, PStructure d, PStructure e, PStructure f)
newStruc = first Tuple6 <$> newPVar
writeStruc (Tuple6 pv) _ = do (pa, a) <- newStruc
(pb, b) <- newStruc
(pc, c) <- newStruc
(pd, d) <- newStruc
(pe, e) <- newStruc
(pf, f) <- newStruc
writePVar pv (a, b, c, d, e, f)
return (pa, pb, pc, pd, pe, pf)
data MaybeC = NothingC | JustC
instance Structure a => Structure (Maybe a) where
type Constructor (Maybe a) = MaybeC
newtype PStructure (Maybe a) = PMaybe (PVar (Maybe a))
type Inner (Maybe a) = Maybe (PStructure a)
newStruc = first PMaybe <$> newPVar
writeStruc (PMaybe pv) NothingC = do writePVar pv Nothing
return Nothing
writeStruc (PMaybe pv) JustC = do (pa, a) <- newStruc
writePVar pv $ Just a
return $ Just pa
data EitherC = LeftC | RightC
instance (Structure a, Structure b) => Structure (Either a b) where
type Constructor (Either a b) = EitherC
newtype PStructure (Either a b) = PEither (PVar (Either a b))
type Inner (Either a b) = Either (PStructure a) (PStructure b)
newStruc = first PEither <$> newPVar
writeStruc (PEither pv) LeftC = do (pa, a) <- newStruc
writePVar pv $ Left a
return $ Left pa
writeStruc (PEither pv) RightC = do (pb, b) <- newStruc
writePVar pv $ Right b
return $ Right pb
data ListC = NilC | ConsC
instance Structure a => Structure [a] where
type Constructor [a] = ListC
newtype PStructure [a] = PList (PVar [a])
type Inner [a] = Maybe (PStructure a, PStructure [a])
newStruc = first PList <$> newPVar
writeStruc (PList pv) NilC = do writePVar pv []
return Nothing
writeStruc (PList pv) ConsC = do (ph, h) <- newStruc
(pt, t) <- newStruc
writePVar pv $ h:t
return $ Just (ph, pt)