{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FlexibleContexts #-}

--module Test where

import Data -- Siso is independent of the data language.
import Eval -- Haskell Evaluation DSL semantics
import Code -- Code generator DSL semantics
import Vec

import Signal  -- (Compilable) causal signal abstraction
import RSig    -- Signal as representations

import Lib

import Prelude hiding ((.), id)
import Control.Category
import Control.Applicative
import Control.Monad
import Control.Arrow

import LLVM.General.Module
import LLVM.General.Context
import LLVM.General.AST
import LLVM.General.AST.Global

-- Shortcuts for specifying Sig Comp types.
type CI   = Code Tint
type CR   = Code Treal
type SigC = Signal Comp
type CVI  = Code (CVec Tint)

type SCI   = SigC CI
type SCII  = SigC (CI,CI)

type SCiI  = SigC CI -> SigC CI
type SCiiI = SigC CI -> SigC CI -> SigC CI

type CiiI' = (CI,CI) -> Comp CI

-- uncurried
type SCiiI' = SigC (CI,CI) -> SigC CI

evalTest_I    sig = take 5 $ runSig sig :: [Tint]
evalTest_II'  sig = take 5 $ runSig sig :: [(Tint,Tint)]
evalTest_iI   f i = take 5 $ runSig (f $ cycleSig i) :: [Tint]

compTest      x = compile x initComp
compTest_I    x = compTest (x :: SCI)
compTest_iI   x = compTest (x :: SCiI)
compTest_iiI  x = compTest (x :: SCiiI)
compTest_iiI' x = compTest (x :: SCiiI')

info name obj =
  putStrLn $ "\n-- " ++ name ++ ":\n" ++ (show obj)


ramp2 = Signal zero $ \s -> do
  s' <- add s one
  return (s', cons s' s')

accu = sys zero $ \i s -> do
  s' <- add s i
  return (s', s')


add2 (a1,a2) (b1, b2) = do
  c1 <- add a1 b1
  c2 <- add a2 b2
  return (c1, c2)
padd2 a b = do
  (c1, c2) <- add2 (uncons a) (uncons b)
  return $ cons c1 c2
vpadd2 :: Code (CVec (Int, Int)) -> Comp (Code (Int, Int))
vpadd2 = vfold padd2 $ cons zero zero

-- To compile n-ary Kleisly arrows, use uncurry.
uncurry3 = uncurry . uncurry
uncurry4 = uncurry . uncurry3

square x = mul x x
sumsq v = (vmap square v) >>= vsum

main = do
  info "runSig ramp"    $ evalTest_I  ramp
  info "runSig ramp2"   $ evalTest_II'  ramp2 -- FIXME: tuple problem
  info "runSig accu"    $ evalTest_iI accu [1,1,1,1,1]
  info "compSig ramp"    $ compTest_I  ramp
  info "compSig accu"    $ compTest_iI accu
  info "compSig accu^3"  $ compTest_iI $ accu . accu . accu
  info "compSig add"     $ compTest_iiI  $ liftS2 add
  info "compSig add'"    $ compTest_iiI' $ liftS $ uncurry add
  info "comp vsum"       $ compTest (vsum :: CVI -> Comp CI)
  -- info "compTest vpadd2"  $ compTest $ vpadd2  -- Broken.  Do we need vectors of tuples?
  info "uncurry vref :: (CVI,CI) -> Comp CI" $ compTest ((uncurry vref) :: (CVI,CI) -> Comp CI)
  info "while" $ compTest (while (\x -> eq  x x)
                                 (\x -> add x x)
                                 zero :: Comp CI)
   
  info "sumsq" $ compTest (sumsq :: CVI -> Comp CI)




-- Documentation.
-- Proofs for some illustrative isomorphisms.

-- Applicative form to normal form.
p1 :: Monad m =>
      (s -> m (s, i -> m o)) ->
      s -> m (i -> m (s, o))
p1 f s = return (\i -> do
                    (s', f') <- f s
                    o <- f' i
                    return (s', o))

-- Update equation form to normal form
p2 :: Monad m =>
      (s -> i -> m (s, o)) ->
      s -> m (i -> m (s, o))
p2 f s = return (\i -> f s i)

-- Update equation inside monad.
p3 :: Monad m =>
      (s -> m (i -> m (s, o))) ->
      m (s -> i -> m (s, o))
p3 f = return (\s i -> do; f' <- f s; f' i)

-- Lift inputs out again.
p4 :: Monad m =>
      (m (s -> i -> m (s, o))) ->
      s -> i -> m (s, o)
p4 mf s i = do; f <- mf; f s i

-- Convert signal operator to siso.
--
-- This needs rank2 types to express properly:
-- * p5 is polynorphic in s
-- * f  is polymorphic in s1 (but we could specialize to ())
p5 :: Monad m =>
      ((s1 -> m (s1, i)) -> s -> m (s, o)) ->
      s -> i -> m (s, o)
p5 f s i = (f (\_ -> return (undefined, i))) s