{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -O0 -fno-omit-interface-pragmas #-}

module CLaSH.Prelude
  ( module Exported
  , module CLaSH.Prelude
  )
where

import Control.Arrow         as Exported
import Control.Applicative   as Exported
import Control.Category      as Category
import Data.Bits             as Exported
import Data.Default          as Exported
import CLaSH.Class.BitVector as Exported
import CLaSH.Promoted.Bool   as Exported
import CLaSH.Promoted.Nat    as Exported
import CLaSH.Promoted.Ord    as Exported
import CLaSH.Sized.Signed    as Exported
import CLaSH.Sized.Unsigned  as Exported
import CLaSH.Sized.Vector    as Exported
import CLaSH.Bit             as Exported
import CLaSH.Signal          as Exported
import GHC.TypeLits          as Exported

{-# INLINABLE window #-}
window :: (KnownNat (n + 1), Default a)
       => Signal a
       -> Vec ((n + 1) + 1) (Signal a)
window x = x :> prev
  where
    prev = registerP (vcopyI def) next
    next = x +>> prev

{-# INLINABLE windowP #-}
windowP :: (KnownNat (n + 1), Default a)
        => Signal a
        -> Vec (n + 1) (Signal a)
windowP x = prev
  where
    prev = registerP (vcopyI def) next
    next = x +>> prev

{-# INLINABLE (<^>) #-}
(<^>) :: (Pack i, Pack o)
      => (s -> i -> (s,o))
      -> s
      -> (SignalP i -> SignalP o)
f <^> iS = \i -> let (s',o) = unpack $ f <$> s <*> (pack i)
                     s      = register iS s'
                 in unpack o

{-# INLINABLE registerP #-}
registerP :: Pack a => a -> SignalP a -> SignalP a
registerP i = unpack Prelude.. register i Prelude.. pack

{-# NOINLINE blockRam #-}
blockRam :: forall n m a . (KnownNat n, KnownNat m, Pack a)
         => SNat n
         -> Signal (Unsigned m)
         -> Signal (Unsigned m)
         -> Signal Bool
         -> Signal a
         -> Signal a
blockRam n wr rd en din = pack $ (bram' <^> binit) (wr,rd,en,din)
  where
    binit :: (Vec n a,a)
    binit = (vcopy n (error "uninitialized ram"),error "uninitialized ram")

    bram' :: (Vec n a,a) -> (Unsigned m, Unsigned m, Bool, a)
          -> (((Vec n a),a),a)
    bram' (ram,o) (w,r,e,d) = ((ram',o'),o)
      where
        ram' | e         = vreplace ram w d
             | otherwise = ram
        o'               = ram ! r

{-# INLINABLE blockRamPow2 #-}
blockRamPow2 :: (KnownNat n, KnownNat (n^2), Pack a)
             => (SNat ((n^2) :: Nat))
             -> Signal (Unsigned n)
             -> Signal (Unsigned n)
             -> Signal Bool
             -> Signal a
             -> Signal a
blockRamPow2 = blockRam

newtype Comp a b = C { asFunction :: Signal a -> Signal b }

instance Category Comp where
  id            = C Prelude.id
  (C f) . (C g) = C (f Prelude.. g)

infixr 8 ><
(><) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
(f >< g) (x,y) = (f x,g y)

instance Arrow Comp where
  arr         = C Prelude.. fmap
  first (C f) = C $ pack Prelude.. (f >< Prelude.id) Prelude.. unpack

instance ArrowLoop Comp where
  loop (C f) = C $ simpleLoop (unpack Prelude.. f Prelude.. pack)
    where
      simpleLoop g b = let ~(c,d) = g (b,d)
                       in c

registerC :: a -> Comp a a
registerC = C Prelude.. register

simulateC :: Comp a b -> [a] -> [b]
simulateC f = simulate (asFunction f)

{-# INLINABLE (^^^) #-}
(^^^) :: (s -> i -> (s,o)) -> s -> Comp i o
f ^^^ sI = C $ \i -> let (s',o) = unpack $ f <$> s <*> i
                         s      = register sI s'
                     in  o