{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

-- | Tests for various constructs

module Imperative where



import Data.Int
import Data.Word

import Language.Embedded.Imperative
import Language.Embedded.Backend.C
import Language.Embedded.CExp



type CMD
    =   RefCMD
    :+: ArrCMD
    :+: ControlCMD
    :+: PtrCMD
    :+: FileCMD
    :+: C_CMD

type Prog = Program CMD (Param2 CExp CType)

prog :: Prog ()
prog = do
    r <- initRef (10 :: CExp Int32)
    a <- getRef r
    modifyRef r (*a)
    printf "%d\n" a



-- | Test primitive types
testTypes :: Prog ()
testTypes = do
    inp :: CExp Int32 <- fget stdin
    a <- unsafeFreezeRef =<< initRef (i2n inp + 0x88               :: CExp Int8)
    b <- unsafeFreezeRef =<< initRef (i2n inp + 0x8888             :: CExp Int16)
    c <- unsafeFreezeRef =<< initRef (i2n inp + 0x88888888         :: CExp Int32)
    d <- unsafeFreezeRef =<< initRef (i2n inp + 0x8888888888888888 :: CExp Int64)
    e <- unsafeFreezeRef =<< initRef (i2n inp + 0xEE               :: CExp Word8)
    f <- unsafeFreezeRef =<< initRef (i2n inp + 0xEEEE             :: CExp Word16)
    g <- unsafeFreezeRef =<< initRef (i2n inp + 0xEEEEEEEE         :: CExp Word32)
    h <- unsafeFreezeRef =<< initRef (i2n inp + 0xEEEEEEEEEEEEEEEE :: CExp Word64)
    i <- unsafeFreezeRef =<< initRef (i2n inp - 9                  :: CExp Float)
    j <- unsafeFreezeRef =<< initRef (i2n inp - 10                 :: CExp Double)
    printf "%d %d %d %ld %u %u %u %lu %.3f %.3f\n" a b c d e f g h i j
    k1 <- unsafeFreezeRef =<< initRef true
    k2 <- unsafeFreezeRef =<< initRef true
    iff ((k1 #&& k2) #|| not_ k1) (printf "true") (printf "false")

testCExp :: Prog ()
testCExp = do
    a :: CExp Int32 <- fget stdin
    let b = a#==10 ? a*3 $ a-5+8
    let c = sin (i2n a) :: CExp Double
    let d = c/23
    printf "%d " b
    printf "%d " (not_ (a#==10) ? a*3 $ a-5+8)
    printf "%d " (a `quot_` b)
    printf "%d " (a #% b)
    printf "%d " (cond (i2b a) a b)
    printf "%d " (b2i (not_ (a#==10)) * a)
    printf "%.3f " c
    printf "%.3f " d
    printf "%.3f " (i2n a :: CExp Float)
    printf "%ld "  (round_ (c*1000)              :: CExp Int32)
    printf "%d "   (round_ (11.5 :: CExp Float)  :: CExp Int32)
    printf "%d "   (round_ (-11.5 :: CExp Float) :: CExp Int32)
    printf "%.3f " (c**d)

testRef :: Prog ()
testRef = do
    r1 <- newRef
    r2 <- initRef (3 :: CExp Int32)
    modifyRef r2 (*2)
    setRef r1 =<< getRef r2
    a <- unsafeFreezeRef r1
    b <- unsafeFreezeRef r2
    printf "%d %d\n" a b

testArr1 :: Prog ()
testArr1 = do
    arr1 :: Arr Word32 Int32 <- newArr (10 :: CExp Word32)
    arr2 :: Arr Word32 Int32 <- newArr (10 :: CExp Word32)
    sequence_ [setArr i (i2n i+10) arr1 | i' <- [0..9], let i = fromInteger i']
    copyArr arr2 arr1 10
    sequence_ [getArr i arr2 >>= printf "%d " . (*3) | i' <- [0..9], let i = fromInteger i']
    printf "\n"

testArr2 :: Prog ()
testArr2 = do
    n <- fget stdin
    arr :: Arr Word32 Int32 <- newArr n  -- Array of dynamic length
    sequence_ [setArr (i2n i) i arr | i' <- [0..3], let i = fromInteger i']
    sequence_ [getArr i arr >>= printf "%d " . (*3) | i' <- [0..3], let i = fromInteger i']
    printf "\n"
    return ()

testArr3 :: Prog ()
testArr3 = do
    arr :: Arr Word32 Int32 <- initArr [8,7,6,5]
    sequence_ [getArr i arr >>= printf "%d " . (*3) | i' <- [0..3], let i = fromInteger i']
    printf "\n"
    return ()

testArr4 :: Prog ()
testArr4 = do
    arr :: Arr Word32 Int32 <- initArr [8,7,6,5]
    iarr <- freezeArr arr 4
    sequence_ [printf "%d " $ iarr #! i | i' <- [0..3], let i = fromInteger i']
    printf "\n"

testArr5 :: Prog ()
testArr5 = do
    arr :: Arr Word32 Int32 <- initArr [8,7,6,5]
    iarr <- unsafeFreezeArr arr
    sequence_ [printf "%d " $ iarr #! i | i' <- [0..3], let i = fromInteger i']
    printf "\n"

testArr6 :: Prog ()
testArr6 = do
    arr :: Arr Word32 Int32 <- initArr [8,7,6,5]
    iarr <- unsafeFreezeArr arr
    arr2 <- unsafeThawArr iarr
    sequence_ [getArr i arr2 >>= printf "%d " | i <- map fromInteger [0..3]]
    printf "\n"

testArr7 :: Prog ()
testArr7 = do
    arr :: Arr Word32 Int32 <- initArr [8,7,6,5]
    iarr <- freezeArr arr 4
    arr2 <- thawArr iarr 4
    sequence_ [getArr i arr2 >>= printf "%d " | i <- map fromInteger [0..3]]
    printf "\n"

testSwap1 :: Prog ()
testSwap1 = do
    arr1 :: Arr Word32 Int32 <- initArr [1,2,3,4]
    arr2 :: Arr Word32 Int32 <- initArr [11,12,13,14]
    unsafeSwap arr1 arr2
    sequence_ [getArr i arr1 >>= printf "%d " | i <- map fromInteger [0..3]]
    printf "\n"

testSwap2 :: Prog ()
testSwap2 = do
    arr1 :: Arr Word32 Int32 <- initArr [1,2,3,4]
    n <- fget stdin
    arr2 :: Arr Word32 Int32 <- newArr n
    copyArr arr2 arr1 4
    setArr 2 22 arr2
    unsafeSwap arr1 arr2
    sequence_ [getArr i arr1 >>= printf "%d " | i <- map fromInteger [0..3]]
    printf "\n"
    sequence_ [getArr i arr2 >>= printf "%d " | i <- map fromInteger [0..3]]
    printf "\n"

testIf1 :: Prog ()
testIf1 = do
    inp :: CExp Int32 <- fget stdin
    a <- ifE (inp #== 10)        (return (inp+1)) (return (inp*3))
    b <- ifE (not_ (inp #== 10)) (return (a+1))   (return (a*3))
    printf "%d %d\n" a b

testIf2 :: Prog ()
testIf2 = do
    inp :: CExp Int32 <- fget stdin
    iff (inp #== 11)        (printf "== 11\n") (printf "/= 11\n")
    iff (not_ (inp #== 11)) (printf "/= 11\n") (printf "== 11\n")
    iff (inp #== 12)        (printf "== 12\n") (return ())
    iff (not_ (inp #== 12)) (return ())        (printf "== 12\n")
    iff (inp #== 13)        (printf "== 13\n") (return ())
    iff (not_ (inp #== 13)) (return ())        (printf "== 13\n")
    iff (inp #== 14)        (return ())        (return ())

-- Loop from 0 to 9 in steps of 1
testFor1 :: Prog ()
testFor1 = for (0,1,9) $ \i ->
    printf "%d\n" (i :: CExp Int8)

-- Loop from 9 to 0 in steps of 2
testFor2 :: Prog ()
testFor2 = for (9,-2,0) $ \i ->
    printf "%d\n" (i :: CExp Int8)

-- Loop from 0 to but excluding 10 in steps of 2
testFor3 :: Prog ()
testFor3 = for (0, 2, Excl 10) $ \i ->
    printf "%d\n" (i :: CExp Int8)

-- While loop tested in `sumInput` in Demo.hs.

testAssert :: Prog ()
testAssert = do
    inp :: CExp Int32 <- fget stdin
    assert (inp #> 0) "input too small"
    printf "past assertion\n"

testPtr :: Prog ()
testPtr = do
    addInclude "<stdlib.h>"
    addInclude "<string.h>"
    addInclude "<stdio.h>"
    p :: Ptr Int32 <- newPtr
    callProcAssign p "malloc" [valArg (100 :: CExp Word32)]
    arr :: Arr Word32 Int32 <- initArr [34,45,56,67,78]
    callProc "memcpy" [ptrArg p, arrArg arr, valArg (5*4 :: CExp Word32)]  -- sizeof(int32_t) = 4
    callProc "printf" [strArg "%d\n", deref $ ptrArg p]
    iarr :: IArr Word32 Int32 <- unsafeFreezeArr =<< ptrToArr p
    printf "sum: %d\n" (iarr#!0 + iarr#!1 + iarr#!2 + iarr#!3 + iarr#!4)
    callProc "free" [ptrArg p]

testArgs :: Prog ()
testArgs = do
    addInclude "<stdio.h>"
    addDefinition setPtr_def
    addDefinition ret_def
    let v = 55 :: CExp Int32
    r <- initRef (66 :: CExp Int32)
    a :: Arr Int32 Int32 <- initArr [234..300]
    ia <- freezeArr a 10
    p :: Ptr Int32 <- newPtr
    o <- newObject "int" False
    op <- newObject "int" True
    callProcAssign p "setPtr" [refArg r]
    callProcAssign o "ret" [valArg v]
    callProcAssign op "setPtr" [refArg r]
    callProc "printf"
        [ strArg "%d %d %d %d %d %d %d\n"
        , valArg v
        , deref (refArg r)
        , deref (arrArg a)
        , deref (iarrArg ia)
        , deref (ptrArg p)
        , objArg o
        , deref (objArg op)
        ]
  where
    setPtr_def = [cedecl|
        int * setPtr (int *a) {
            return a;
        }
        |]
    ret_def = [cedecl|
        int ret (int a) {
            return a;
        }
        |]

testExternArgs :: Prog ()
testExternArgs = do
    let v = 55 :: CExp Int32
    externProc "val_proc" [valArg v]
    r <- initRef v
    externProc "ref_proc1" [refArg r]
    externProc "ref_proc2" [deref $ refArg r]  -- TODO Simplify
    a :: Arr Int32 Int32 <- newArr 10
    externProc "arr_proc1" [arrArg a]
    externProc "arr_proc2" [addr $ arrArg a]
    externProc "arr_proc3" [deref $ arrArg a]
    p :: Ptr Int32 <- newPtr
    externProc "ptr_proc1" [ptrArg p]
    externProc "ptr_proc2" [addr $ ptrArg p]
    externProc "ptr_proc3" [deref $ ptrArg p]
    o <- newObject "int" False
    externProc "obj_proc1" [objArg o]
    externProc "obj_proc2" [addr $ objArg o]
    op <- newObject "int" True
    externProc "obj_proc3" [objArg op]
    externProc "obj_proc4" [addr $ objArg op]
    externProc "obj_proc5" [deref $ objArg op]
    let s = "apa"
    externProc "str_proc1"  [strArg s]
    externProc "str_proc2"  [deref $ strArg s]
    return ()



----------------------------------------

-- It would be nice to be able to run these tests using Tests.Tasty.HUnit, but
-- I wasn't able to make that work, probably due to the use of `fakeIO` in the
-- tests. First, Tasty wasn't able to silence the output of the tests, and
-- secondly, the tests would always fail when running a second time.

testAll = do
    tag "testTypes"  >> compareCompiled  testTypes  (runIO testTypes)                      "0\n"
    tag "testCExp"   >> compareCompiledM testCExp   (runIO testCExp)                       "44\n"
    tag "testRef"    >> compareCompiled  testRef    (runIO testRef)                        ""
    tag "testArr1"   >> compareCompiled  testArr1   (runIO testArr1)                       ""
    tag "testArr2"   >> compareCompiled  testArr2   (runIO testArr2)                       "20\n"
    tag "testArr3"   >> compareCompiled  testArr3   (runIO testArr3)                       ""
    tag "testArr4"   >> compareCompiled  testArr4   (runIO testArr4)                       ""
    tag "testArr5"   >> compareCompiled  testArr5   (runIO testArr5)                       ""
    tag "testArr6"   >> compareCompiled  testArr6   (runIO testArr6)                       ""
    tag "testArr7"   >> compareCompiled  testArr7   (runIO testArr6)                       ""
    tag "testArr7"   >> compareCompiled  testArr7   (runIO testArr7)                       ""
    tag "testSwap1"  >> compareCompiled  testSwap1  (runIO testSwap1)                      ""
    tag "testSwap2"  >> compareCompiled  testSwap2  (runIO testSwap2)                      "45\n"
    tag "testIf1"    >> compareCompiled  testIf1    (runIO testIf1)                        "12\n"
    tag "testIf2"    >> compareCompiled  testIf2    (runIO testIf2)                        "12\n"
    tag "testFor1"   >> compareCompiled  testFor1   (runIO testFor1)                       ""
    tag "testFor2"   >> compareCompiled  testFor2   (runIO testFor2)                       ""
    tag "testFor3"   >> compareCompiled  testFor3   (runIO testFor3)                       ""
    tag "testAssert" >> compareCompiled  testAssert (runIO testAssert)                     "45"
    tag "testPtr"    >> compareCompiled  testPtr    (putStrLn "34" >> putStrLn "sum: 280") ""
    tag "testArgs"   >> compareCompiled  testArgs   (putStrLn "55 66 234 234 66 55 66")    ""
    tag "testExternArgs" >> compileAndCheck  testExternArgs
  where
    tag str = putStrLn $ "---------------- tests/Imperative.hs/" ++ str ++ "\n"
    compareCompiledM = compareCompiled'
        defaultExtCompilerOpts {externalFlagsPost = ["-lm"]}