{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses
           , TypeSynonymInstances
  #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
----------------------------------------------------------------------
-- |
-- Module      :  Signal
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Signals -- an experiment in relative-time, comonadic FRP
----------------------------------------------------------------------

module Signal where

import Prelude hiding (null,length,drop,take,splitAt,zip,unzip)

import Data.Monoid
import Control.Applicative (Applicative(..),liftA2,(<$>))
-- import Data.List (tails)

import Control.Comonad    -- from category-extras

import Data.Zip  -- from TypeCompose

import Segment

-- | Signal indexed by @t@ with values of type @a@.  Semantically
-- equivalent to '(:->)', but can be used more efficiently.
newtype t :-> a = S { unS :: [t :-># a] }

-- TODO: Generalize 'S' to arbitrary applicative segment constructors

meaning :: (Ord t, Num t) => (t :-> a) -> (t :-># a)
meaning = mconcat . unS


inS :: ([s :-># a] -> [t :-># b])
    -> ((s :->  a) -> (t :->  b))
inS = result S . argument unS

inS2 :: ([s :-># a] -> [t :-># b] -> [u :-># c])
     -> ((s :->  a) -> (t :->  b) -> (u :->  c))
inS2 = result inS . argument unS


-- instance Functor (S t) where
--     fmap h (S ss) = S (fmap (fmap h) ss)

-- instance (Ord t, Num t, Bounded t) => Applicative (S t) where
--     pure a = S [pure a]  -- pure = S . pure . pure
--     S fss <*> S xss = S (fss `appl` xss)

instance Functor ((:->) t) where
    fmap = inS . fmap . fmap

instance (Ord t, Num t, Bounded t) => Applicative ((:->) t) where
    pure  = S . pure . pure
    (<*>) = inS2 appl

-- We could do without Bounded for 'pure' if we instead made an infinite
-- list of segments.  They might all be a standard length or perhaps
-- double in length.

appl :: (Ord t, Num t, Bounded t) =>
        [t :-># (a -> b)] -> [t :-># a] -> [t :-># b]

[] `appl` _  = []
_  `appl` [] = []

-- appl :: ( Segment (f (a -> b)) dur, Segment (f a) dur
--         , Applicative f, Ord dur ) =>
--         [f (a -> b)] -> [f a] -> [f b]

(fs:fss') `appl` (xs:xss')
   | fd == xd  = (fs  <*> xs ) : (fss' `appl`       xss' )
   | fd <  xd  = (fs  <*> xs') : (fss' `appl` (xs'':xss'))
   | otherwise = (fs' <*> xs ) : ((fs'':fss') `appl` xss')
 where
   fd         = length fs
   xd         = length xs
   (fs',fs'') = splitAt xd fs
   (xs',xs'') = splitAt fd xs

instance (Ord t, Num t, Bounded t) => Zip ((:->) t) where
    zip = liftA2 (,)

-- instance Monoid (t :-> a) where
--   mempty = S []
--   S xss `mappend` S yss = S (xss ++ yss)

instance Monoid (t :-> a) where
    mempty  = S mempty
    mappend = inS2 mappend


instance (Ord t, Num t) => Segment (t :-> a) t where
  null   (S xss) = null xss
  -- If we allow empty function segments:
  --   null   (S xss) = all null xss
  length (S xss) = sum (length <$> xss)

  splitAt _ (S [])  = (mempty,mempty)
  splitAt d b | d <= 0 = (mempty, b)
  splitAt d (S (xs:xss')) =
    case (d `compare` xd) of
      EQ -> (S [xs], S xss')
      LT -> let (xs',xs'') = splitAt d xs in
              (S [xs'], S (xs'':xss'))
      GT -> let (S uss, suffix) = splitAt (d-xd) (S xss') in
              (S (xs:uss), suffix)
   where
     xd = length xs

instance Num t => Copointed ((:->) t) where
    extract (S [])     = error "extract: empty S"
    extract (S (xs:_)) = extract xs

-- Prettier definition but less helpful error message:

-- instance Num t => Copointed ((:->) t) where
--     extract = extract . extract . unS

-- If we allow empty function segments:
-- 
--   instance Num t => Copointed ((:->) t) where
--       extract (S []) = error "extract: empty S"
--       extract (S (xs:xss'))
--         | null xs     = extract (S xss')
--         | otherwise   = extract xs

instance (Ord t, Num t) => Comonad ((:->) t) where
    duplicate = fmap S . inS dup


dup :: (Ord t, Num t) =>
       [t :-># a] -> [t :-># [t :-># a]]

dup []        = [mempty]

dup (xs:xss') = ((:xss') <$> duplicate xs) : dup xss'



--------  Generally useful

result :: (b -> b') -> ((a -> b) -> (a -> b'))
result = (.)

argument :: (a' -> a) -> ((a -> b) -> (a' -> b))
argument = flip (.)


-- instance Copointed [] where
--   extract []    = error "extract: []"
--   extract (x:_) = x

-- instance Copointed [] where extract   = head  -- beware: may fail!
-- instance Comonad   [] where duplicate = tails