{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, 
NoMonomorphismRestriction, FlexibleContexts, ExistentialQuantification, 
FunctionalDependencies, ScopedTypeVariables, UndecidableInstances,
TypeOperators #-}

-- Test for multiple arity functions.

import Control
import Data
import Array
import Struct

import Type
import Term
import Control.Monad.Identity
import Control.Monad.ST
import Data.Array.ST
import Data.Array.MArray
import Data.Array.Base
import Code
import Value

import PrettyC

import qualified Text.Show.Pretty

pp = putStr . Text.Show.Pretty.ppShow 
ctop t = code $ termTopdef t

-- TODO: probably pack / unpack can be combined with lam / app to
-- make this multiple arity juggling invisible.
  
  
-- TODO: write generic unpack / pack in terms of _uncons / _cons
  
-- To fix the return type of a Loop expression.  
n = 0 :: Tint
exit = do
  ln <- lit n
  ret $ ln

t1 = do { v <- lit 123 ; ret v }
t2 = do
  t <- true
  zero <- lit (0 :: Tint)
  one  <- lit (1 :: Tint)
  ifte t (ret one) (ret zero)



-- Single recursion
-- f1 :: (Args r as ras, Loop m r) => r (as -> m t)
f1 = lam $ \a -> do
  f <- f1
  app f a
  
f2 = lam $ \((,) (L a) (L b)) -> do 
  f <- f2
  app f ((,) (L b) (L a))


-- Mutual recursion
f3 = lam $ \a -> do
  f <- f4
  app f a
f4 = lam $ \a -> do
  f <- f3
  app f a


-- Simple functions
f5 = lam $ \(L a) -> ret a
f6 = lam $ \(L a) -> do
  square <- mul a a
  ret square

-- Simple function, tuple input

f7 = lam $ \((,) (L a) (L b)) ->
  do { v <- add a b ; ret v }


f7' = \(a,b) -> do {v <- add a b; ret v}

-- Casting seems necessary
type V1 = MValue (Value (L Tint -> MValue Tint))
type VI = MValue (Value (L Tint))


t3 = do
  f <- (f1 :: V1)
  l1 <- lit 1
  app f $ L l1

t4 = do
  f <- (f5 :: V1)
  l1 <- lit 1
  app f $ L l1
  

t5 = do
  l2 <- lit 2
  f <- (f6 :: V1)
  app f $ L l2


type C1 = MCode (Code (L Tint -> MCode Tint))
type CI = MCode (Code Tint)

t6 = do
  l1 <- lit 1
  f <- (f1 :: C1)
  app f $ L l1


t7 = do
  l1 <- lit 1
  f <- (f5 :: C1)
  app f $ L l1
  

t8 = do
  l2 <- lit 2  
  f <- (f6 :: C1)
  app f $ L l2


-- test Lambda
t9 = term (f5 :: C1)
t10 = term (f6 :: C1)

-- Multi-arg
type V2 = MValue (Value ((Tint, Tint) -> MValue Tint))
type C2 = MCode (Code (((,) (L Tint) (L Tint)) -> MCode Tint))

t11 = term (f2 :: C2)

t12 = do
  f <- (f2 :: C2)
  l1 <- lit 1
  l2 <- lit 2
  app f $ ((,) (L l1) (L l2))

t13 = term (f7 :: C2)


t15 = term $ do
  l1 <- lit 1
  l2 <- lit 2
  f  <- (f7 :: C2)
  app f $ ((,) (L $ l1) (L $ l2))

t16 = term $ do
  f <- (f7 :: C2)
  l1 <- lit 1
  l2 <- lit 2  
  app f $ ((,) (L $ l1) (L $ l2))


{- I think this needs a signature because the return value is not
   specified, and since it's a loop that seems quite plausible. -}
  
t17def :: (Repr r,
           StructVar (L (r Tint)),
           StructRepr r,
           Control m r,
           Data m r) =>
          r (L Tint -> m Tint) -> m (r (L Tint -> m Tint))
          
t17def = \f -> lam $ (\(L x) -> do
                             x2 <- mul x x
                             app f $ L x2)
               
t17exp = \f -> do
  l123 <- lit 123
  app f $ L $ l123

t17 = term $ letrec t17def t17exp


t18 = term $ letrec 
      t17def $
      \f -> do 
        l3 <- lit 3
        l4 <- lit 4
        x <- mul l3 l4
        y <- mul x x
        app f (L y)




a1 inArray outArray = do
  -- (inFirst,  inLast,  inStride)  <- _bounds inArray
  -- (outFirst, outLast, outStride) <- _bounds outArray
  -- We assume that output and input dims are compatible, ignoring
  -- inLast (or equivalently outLast).
  i <- lit 1
  v <- get inArray i
  set outArray i v
  exit
      
int n = Lit (Type AInt 0) (show n)

varArr :: String -> Code (Tint -> Tint)
varArr name =  Code $ Ref $ Var (Type AInt 1) name


t19 = term $ a1 (varArr "in") (varArr "out")
      


-- Arrays
t20 = runSTUArray $ newArray ((1 :: Int), (10 :: Int)) (0 :: Int) 

f8 arr = \f ->
  lam $ (\((,) 
               (L accu)
               (L index)) ->
             do
               l1     <- lit 1
               l10    <- lit 10
               v      <- get arr index
               index' <- add index l1
               accu'  <- add accu v
               cond   <- eq index' l10
               ifte cond 
                 (ret accu')
                 (app f $ (,) (L accu') (L index')))



-- t21 :: Array m r a Tint => m (r Tint)
t21 = do
  arr <- (undefined :: m (r (a Tint)))
  letrec
    (f8 arr)
    (\f -> do
        l0 <- lit 0
        app f $ ((,) (L $ l0) (L $ l0)))



t22' = lam $ (\(L ix) -> 
                   letrec 
                   (\f -> lam $ (\(L x) -> do
                                        x2 <- mul x x
                                        ltt <- lit (10000 :: Tint)
                                        cond <- lt x2 ltt
                                        ifte cond
                                          (app f $ L x2)
                                          (ret x)
                                    ))
                   (\f -> app f $ L $ ix))


t22 = term t22'

t23 :: MValue (Value Tint)
t23 = do 
  f <- t22'
  l3 <- lit 3
  app f $ L l3 
    


t24' = lam1 $ (\ix -> 
                letrec 
                (\f -> lam1 $ (\x -> do
                                  x2 <- mul x x
                                  ltt <- lit (10000 :: Tint)
                                  cond <- lt x2 ltt
                                  ifte cond
                                    (app1 f x2)
                                    (ret x)
                              ))
                (\f -> app1 f ix))

t24 = do {f <- t24'; l3 <- lit 3; app1 f l3} :: MValue (Value Tint)


t25 = term $ do
  l1 <- lit (1 :: Tint)
  l2 <- lit (2 :: Tint)
  l3 <- lit (3 :: Tint)
  pack (L $ l1,
        (L $ l2,
         L $ l3))

t26 = term $ do
  l1 <- lit (1 :: Tint)
  l2 <- lit (2 :: Tint)
  l3 <- lit (3 :: Tint)  
  p <- pack (L $ l1,
             (L $ l2,
              L $ l3))
  (L a, (L b, L c)) <- unpack p
  ret b
  
{-
s27 arr = lam body where
  body s = do
    l <- lit (0 :: Tint)
    v <- get arr n
...
-}


                     
main =  putStrLn $ show $ t26