{-# LANGUAGE TypeFamilies #-}

-- Module      :  Data.PVar.Structure
-- Copyright   :  (c) Jake McArthur 2009
-- License     :  ISC
--
-- Maintainer  :  Jake.McArthur@gmail.com
-- Stability   :  experimental
-- Portability :  portable

{-|

  This module provides the 'Structure' type class, enabling you to
  create a pure data structure, which is available immediately, and
  then gradually fill it in using the 'IO' monad. This means that you
  can go ahead and start using the structure before it is fully
  defined. If a part of the structure is evaluated before it has been
  written then that part is treated as @_|_@. This is technically more
  pure than values from 'unsafeInterleaveIO'. Evaluating the
  structure, even before it is defined, doesn't perform any IO. All
  the IO happens in the 'IO' monad.

  Here is an example of creating a list of 'Int's and then writing
  each level of it step by step. The returned result is @[5]@.

  > foo :: IO [Int]
  > foo = do
  >
  >   -- Create the pure list and the handle for writing to it.
  >   (pxs, xs) <- newStruc
  >
  >   -- Write the cons constructor to the list. This gives us handles
  >   -- for writing the head and tail of the list.
  >   Just (h, t) <- writeStruc pxs ConsC
  >
  >   -- Write the head of the list.
  >   writeStruc h 5
  >
  >   -- Write the tail of the list. This finishes it.
  >   writeStruc t NilC
  >
  >   -- Get rid of the Value wrapper on the list's value and return
  >   -- the resulting list.
  >   return $ map getValue xs

 -}
module Data.PVar.Structure (Structure (..), writeSoleCon, Value (..), MaybeC (..), EitherC (..), ListC (..)) where

import Control.Applicative ((<$>))
import Control.Arrow ((***), first)
import Data.PVar

{-|

  A structure type is one which represents any lazy data
  structure. With the exception of the 'Value' newtype wrapper, there
  is little reason to define an instance of 'Structure' for completely
  strict types. This is because the entire thing must be defined at
  once anyway, so you might as well just use a 'PVar'.

 -}
class Structure a where

    -- | A type representing the structure's constructors by
    --   themselves along with any strict data to go along with the
    --   head of the structure.
    type Constructor a

    -- | The internal representation of the handle for writing values
    --   in IO.
    data PStructure a

    -- | The result type from writing the head of the structure. This
    --   is to access deeper levels of the structure.
    type Inner a

    -- | Create a new structure and a handle for writing to it.
    newStruc :: IO (PStructure a, a)

    -- | Write the specified constructor to the given handle and
    --   return whatever other handles are necessary to write deeper
    --   levels of the structure.
    writeStruc :: PStructure a -> Constructor a -> IO (Inner a)

-- | Write the constructor for a structure with only one possible
--   structure, assuming that the 'Constructor' type for that type is
--   ().
writeSoleCon :: (Structure a, Constructor a ~ ()) => PStructure a -> IO (Inner a)
writeSoleCon = flip writeStruc ()

-- | Treat the wrapped value as an atomic structure. This has the same
--   effect as a 'PVar', but allows you to use the 'Structure'
--   interface. This is also necessary for the leaves of most
--   structures.
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)

-- | Constructors for the 'Maybe' instance.
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

-- | Constructors for the 'Either' instance.
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

-- | Constructors for the list instance.
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)