Parameter.hs

-- | This module contains a datatype 'Field' and sone type classes. It is used
--   to construct record-like datatypes.

module Sound.Hommage.Parameter
 ( 
 -- | Example:
 --
 --   To create a \"record\" with the accessors\/modificators first you have to define the type
 --   of the record, It must be a right-associative list of pairs, just like a LISP list.
 --   The rightmost element must be @ () @. The following Example defines a record with information
 --   for music generation. 
 -- 
 -- > type DefaultNote = (Int, (Double, (Char, ())))     
 -- 
 --   Then a default value should be defined. 
 -- 
 -- > defaultNote = (0, (1.0, ('a' , ())))
 -- > defaultNote :: DefaultNote 
 -- 
 --   For each \"datafield\" the 'Field' must be declared.
 -- 
 -- > pitch :: Field DefaultNote Int 
 -- > volume :: Field DefaultNote Double 
 -- > channel :: Field DefaultNote Char 
 --  
 --  Creating the fields is done with 'toField' applied to a value of the \"record\" type.
 --  
 -- > pitch :>> volume :>> channel :>> NilM = toFields defaultNote 
 --  
 --  Is is recommended to declare all types and match all results of 'toFields' incl. the 'NilM' at
 --  the end.
 --
 --  NOTE:
 --
 -- > pitch :>> volume :>> channel :>> NilM = toFields (undefined :: DefaultNote)
 --
 --  should work too.
 --
 
 -- * Field
   Field (..)
 , (<>) 
 , fstField 
 , sndField 
 , UpdateField (..)
 , CheckField (..)
 , updateField 
 , checkField 
 , applyField
 , withField 

 , Group (..)
 , leftGroup 
 , rightGroup 
 , (><) 

 -- * Hetero List
 , LM (..)
 , NilM (..)
 , PushFields (..)
 , ToFields (..)
 , PushGroups (..)
 , ToGroups (..)
 )
 where
-------------------------------------------------------------------------------
infixr 5 :>>

data LM a b m = m a :>> b m


-- | The correct type is: @ data NilM (m :: * -> *) = NilM @ . 
--   (But Haddock rejects this definition. GHC will need it)
--data NilM m = NilM
data NilM (m :: * -> *) = NilM
-------------------------------------------------------------------------------
-- | A @ Field record field @ is an interface to access a type @ field @ which 
--   is part of a type @ record @.
--   A 'Field' is used to access and modify subtypes (\"datafields\") of 
--   a record-like datastructure. In this module, a right-associative pair structure is
--   taken as record-type with \"datafields\" in the fst parts of the pairs.
data Field c a = Field
 { getField :: c -> a
 , setField :: (a -> a) -> c -> c
 }

(<>) :: Field a b -> Field c a -> Field c b
Field g1 f1 <> Field g2 f2 = Field (g1 . g2) (f2 . f1)

fstField :: Field (a,b) a 
fstField = Field fst (\f (a,b) -> (f a, b))

sndField :: Field (a,b) b 
sndField = Field snd (\f (a,b) -> (a, f b))
-------------------------------------------------------------------------------
data UpdateField c = forall a . Field c a := a
                     | forall a . Field c a :$ (a -> a)
                     | If (CheckField c) [UpdateField c] [UpdateField c]

data CheckField c = forall a . Field c a :? (a -> Bool)
                    | And [CheckField c]
                    | Or [CheckField c]

updateField :: UpdateField c -> c -> c
updateField (ctxt := a) = setField ctxt (const a) 
updateField (ctxt :$ f) = setField ctxt f
updateField (If ch u e) = \c -> if checkField ch c then applyField u c else applyField e c

checkField :: CheckField c -> c -> Bool
checkField (ctxt :? p) c = p $ getField ctxt c
checkField (And cs)    c = and $ map (flip checkField c) cs 
checkField (Or  cs)    c = or $ map (flip checkField c) cs 

applyField :: [UpdateField c] -> c -> c
applyField us c = foldl (flip updateField) c us

withField :: [UpdateField a] -> (a -> b) -> a -> b
withField ucs f = f . applyField ucs
-------------------------------------------------------------------------------
class PushFields m where
 pushFields :: m (Field c) -> m (Field (x, c))

instance PushFields NilM where
 pushFields NilM = NilM 

instance PushFields b => PushFields (LM a b) where
 pushFields (ca :>> bc) = (ca <> sndField) :>> pushFields bc
-------------------------------------------------------------------------------
class ToFields a r where
 toFields :: a -> r (Field a)

instance ToFields () NilM where
 toFields _ = NilM

instance (PushFields b', ToFields b b') => ToFields (a, b) (LM a b') where
-- toField (a, b) = fstField :>> pushFields (toField b)
 toFields _ = fstField :>> pushFields (toFields undefined)

--instance (PushFields b', ToField b b') => ToField (L a b) (LM a b') where
-- toField (a :> b) = fstField :>> pushFields (toField b)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
data Group c a = Group 
 { isGroup :: c -> Maybe a
 , mkGroup :: a -> c
 }

leftGroup :: Group (Either a b) a
leftGroup = Group (either Just (const Nothing)) Left

rightGroup :: Group (Either a b) b
rightGroup = Group (either (const Nothing) Just) Right

(><) :: Group a b -> Group c a -> Group c b
Group i1 t1 >< Group i2 t2 = Group (\c -> i2 c >>= i1) (t2 . t1)
-------------------------------------------------------------------------------
class PushGroups m where
 pushGroups :: m (Group c) -> m (Group (Either x c))

instance PushGroups NilM where
 pushGroups NilM = NilM 

instance PushGroups b => PushGroups (LM a b) where
 pushGroups (ca :>> bc) = (ca >< rightGroup) :>> pushGroups bc
-------------------------------------------------------------------------------
class ToGroups a r where
 toGroups :: a -> r (Group a)

instance ToGroups () NilM where
 toGroups _ = NilM

instance (ToGroups b b', PushGroups b') => ToGroups (Either a b) (LM a b') where
 toGroups eab = leftGroup :>> pushGroups (toGroups (either undefined id eab))
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
type DefaultNote1 = (Int, (Double, (Char, ())))     

defaultNote1 :: DefaultNote1 
defaultNote1 = (0, (1.0, ('a' , ())))

pitch1 :: Field DefaultNote1 Int 
volume1 :: Field DefaultNote1 Double 
channel1 :: Field DefaultNote1 Char 

pitch1 :>> volume1 :>> channel1 :>> NilM = toFields defaultNote1
-------------------------------------------------------------------------------
type DefaultNote2 = (Int, (Double, ()))

defaultNote2 :: DefaultNote2
defaultNote2 = (0, (1.0, ()))

pitch2 :: Field DefaultNote2 Int 
volume2 :: Field DefaultNote2 Double 

pitch2 :>> volume2 :>> NilM = toFields defaultNote2
-------------------------------------------------------------------------------
type MixNote = Either DefaultNote1 (Either DefaultNote2 ())

n1 :: Group MixNote DefaultNote1
n2 :: Group MixNote DefaultNote2

n1 :>> n2 :>> NilM = toGroups (undefined :: MixNote)
-------------------------------------------------------------------------------















--data Prop c = forall a . Field c a := a

--def@[ volume := 2.0, trigger := True ] = definition

-------------------------------------------------------------------------------
{-

-------------------------------------------------------------------------------
data Output t a = Output { unOutput :: a -> t }
-------------------------------------------------------------------------------
class PushOutputs m where
 pushOutputs :: m (Output c) -> m (Output (Either x c))

instance PushOutputs NilM where
 pushOutputs NilM = NilM 

instance PushOutputs b => PushOutputs (LM a b) where
 pushOutputs (ca :>> bc) = (Output (Right . unOutput ca)) :>> pushOutputs bc
-------------------------------------------------------------------------------
class ToOutput a r where
 toOutput :: a -> r (Output a)

instance ToOutput () NilM where
 toOutput _ = NilM

instance (ToOutput b b', PushOutputs b') => ToOutput (Either a b) (LM a b') where
 toOutput _ = Output Left :>> pushOutputs (toOutput undefined)
-------------------------------------------------------------------------------
data Filter t a = Filter { unFilter :: t -> Maybe a }
-------------------------------------------------------------------------------
class PushFilters m where
 pushFilters :: m (Filter c) -> m (Filter (Either x c))

instance PushFilters NilM where
 pushFilters NilM = NilM 

instance PushFilters b => PushFilters (LM a b) where
 pushFilters (ca :>> bc) = (Filter (\c -> either (const Nothing) Just c >>= unFilter ca)) :>> pushFilters bc
-------------------------------------------------------------------------------
class ToFilter a r where
 toFilter :: a -> r (Filter a)

instance ToFilter () NilM where
 toFilter _ = NilM

instance (ToFilter b b', PushFilters b') => ToFilter (Either a b) (LM a b') where
 toFilter _ = Filter (either Just (const Nothing)) :>> pushFilters (toFilter undefined)
-------------------------------------------------------------------------------

-}