module Lava.Port where



import Control.Applicative
import Control.Monad
import Data.Foldable (Foldable)
import qualified Data.Foldable as Fold
import Data.List as List
import Data.Traversable (Traversable, traverse)
import qualified Data.Traversable as Trav

import Data.Hardware.Internal
import Lava.Model

import qualified Lava2000 as L



data PortTree s
       = One  {unOne :: s}
       | List [PortTree s]
     deriving (Eq, Show)

instance Functor PortTree
  where
    fmap f (One s)   = One (f s)
    fmap f (List ps) = List $ map (fmap f) ps

instance Foldable PortTree
  where
    foldr f x (One s)   = f s x
    foldr f x (List ps) = List.foldr (flip $ Fold.foldr f) x ps

instance Traversable PortTree
  where
    traverse f (One s)   = pure One  <*> f s
    traverse f (List ps) = pure List <*> traverse (traverse f) ps



class Port p s | p -> s
  where
    port   :: p -> PortTree s
    unport :: PortTree s -> p

instance Port Signal Signal
  where
    port   = One
    unport = unOne

instance Port () ()
  where
    port   = One
    unport = unOne

instance Port Bool Bool
  where
    port   = One
    unport = unOne

instance Port Int Int
  where
    port   = One
    unport = unOne

instance Port (L.Signal Bool) (L.Signal Bool)
  where
    port   = One
    unport = unOne

instance Port p s => Port [p] s
  where
    port             = List . map port
    unport (List ps) = map unport ps

instance (Port p1 s, Port p2 s) => Port (p1,p2) s
  where
    port (p1,p2)          = List [port p1, port p2]
    unport (List [p1,p2]) = (unport p1, unport p2)

instance (Port p1 s, Port p2 s, Port p3 s) => Port (p1,p2,p3) s
  where
    port (p1,p2,p3)          = List [port p1, port p2, port p3]
    unport (List [p1,p2,p3]) = (unport p1, unport p2, unport p3)

instance (Port p1 s, Port p2 s, Port p3 s, Port p4 s) => Port (p1,p2,p3,p4) s
  where
    port (p1,p2,p3,p4)          = List [port p1, port p2, port p3, port p4]
    unport (List [p1,p2,p3,p4]) = (unport p1, unport p2, unport p3, unport p4)



class Port p s => PortStruct p s t | p -> s t, s t -> p

instance PortStruct Signal          Signal          ()
instance PortStruct ()              ()              ()
instance PortStruct Bool            Bool            ()
instance PortStruct Int             Int             ()
instance PortStruct (L.Signal Bool) (L.Signal Bool) ()
instance PortStruct p s t => PortStruct [p] s [t]

instance (PortStruct p1 s t1, PortStruct p2 s t2)
      => PortStruct (p1,p2) s (t1,t2)

instance (PortStruct p1 s t1, PortStruct p2 s t2, PortStruct p3 s t3)
      => PortStruct (p1,p2,p3) s (t1,t2,t3)

instance ( PortStruct p1 s t1
         , PortStruct p2 s t2
         , PortStruct p3 s t3
         , PortStruct p4 s t4
         )
      => PortStruct (p1,p2,p3,p4) s (t1,t2,t3,t4)



mapPort :: (PortStruct pa sa t, PortStruct pb sb t) => (sa -> sb) -> (pa -> pb)
mapPort f = unport . fmap f . port

mapPortM
    :: (PortStruct pa sa t, PortStruct pb sb t, Monad m)
    => (sa -> m sb) -> (pa -> m pb)
mapPortM f = liftM unport . Trav.mapM f . port



class Port p s => PortFixed p s | p -> s
  where
    lengthFP   :: TypeOf p -> Int
    fromListFP :: [s] -> p

instance PortFixed Signal Signal
  where
    lengthFP       = const 1
    fromListFP [s] = s

instance (PortFixed p1 s, PortFixed p2 s) => PortFixed (p1,p2) s
  where
    lengthFP = const $ lengthFP (T::TypeOf p1) + lengthFP (T::TypeOf p2)

    fromListFP ss = (fromListFP ss1, fromListFP ss2)
      where
        (ss1,ss2) = splitAt (lengthFP (T::TypeOf p1)) ss

instance ( PortFixed p1 s
         , PortFixed p2 s
         , PortFixed p3 s
         )
      => PortFixed (p1,p2,p3) s
  where
    lengthFP = const
        $ lengthFP (T::TypeOf p1)
        + lengthFP (T::TypeOf p2)
        + lengthFP (T::TypeOf p3)

    fromListFP ss = (fromListFP ss1, fromListFP ss2, fromListFP ss3)
      where
        (ss1,ss23) = splitAt (lengthFP (T::TypeOf p1)) ss
        (ss2,ss3)  = splitAt (lengthFP (T::TypeOf p2)) ss23

instance ( PortFixed p1 s
         , PortFixed p2 s
         , PortFixed p3 s
         , PortFixed p4 s
         )
      => PortFixed (p1,p2,p3,p4) s
  where
    lengthFP = const
        $ lengthFP (T::TypeOf p1)
        + lengthFP (T::TypeOf p2)
        + lengthFP (T::TypeOf p3)
        + lengthFP (T::TypeOf p4)

    fromListFP ss =
        (fromListFP ss1, fromListFP ss2, fromListFP ss3, fromListFP ss4)
      where
        (ss1,ss234) = splitAt (lengthFP (T::TypeOf p1)) ss
        (ss2,ss34)  = splitAt (lengthFP (T::TypeOf p2)) ss234
        (ss3,ss4)   = splitAt (lengthFP (T::TypeOf p3)) ss34



instance L.Generic (PortTree (L.Signal Bool))
  where
    struct (One (L.Signal sym)) = L.Object sym
    struct (List ss)            = L.Compound (map L.struct ss)

    construct (L.Object sym)  = One (L.Signal sym)
    construct (L.Compound ss) = List (map L.construct ss)

  -- This Lava2000 class corresponds roughly to the Port class.