module PrimTable(module PrimTable) where
import Control.Exception
import Data.Bits
import Data.Char
import Data.Int
import Data.Maybe
import Data.Word
import System.IO
import System.IO.TimeMilli
import Unsafe.Coerce
import GHC.Types(Any)
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Data.Array.IO
import Foreign.Ptr
import GHC.ForeignPtr
--import System.Environment
import System.IO.Unsafe
--import Debug.Trace


type AnyType = Any

type IOArr a = IOArray Int a

_primitive :: String -> Any
--_primitive s | trace ("_primitive " ++ show s) False = undefined
_primitive "dynsym" = unsafeCoerce dynsym
_primitive s = fromMaybe (error $ "PrimTable._primitive: " ++ s) $ lookup s primOps

primOps :: [(String, Any)]
primOps =
  [ comb "S" (\ f g x -> f x (g x))
  , comb "K" const
  , comb "I" id
  , comb "B" (\ f g x -> f (g x))
  , comb "C" (\ f g x -> f x g)
  , comb "S'" (\ k f g x -> k (f x) (g x))
  , comb "B'" (\ k f g x -> k f (g x))
  , comb "C'" (\ k f g x -> k (f x) g)
  , comb "A" (\ _x y -> y)
  , comb "U" (\ x y -> y x)
  , comb "Y" (\ f -> let r = f r in r)
  , comb "Z" (\ f g _x -> f g)
  , comb "J" (\ x _y z -> z x)
  , comb "P" (\ x y f -> f x y)
  , comb "R" (\ x y f -> y f x)
  , comb "O" (\ x y _g f -> f x y)
  , comb "K2" (\ x _y _z -> x)
  , comb "K3" (\ x _y _z _w -> x)
  , comb "K4" (\ x _y _z _w _v -> x)
  , comb "C'B" (\ x y z w -> x z (y w))

  , arith "+" (+)
  , arith "-" (-)
  , arith "*" (*)
  , arith "quot" quot
  , arith "rem" rem
  , arith "subtract" subtract
  , arithu "neg" negate
  , arithu "inv" complement
  , arithw "uquot" quot
  , arithw "urem" rem
  , arithw "and" (.&.)
  , arithw "or" (.|.)
  , arithw "xor" xor
  , arithwi "shl" shiftL
  , arithwi "shr" shiftR
  , arith "ashr" shiftR
  , arithu "popcount" popCount
  , arithu "clz" countLeadingZeros
  , arithu "ctz" countTrailingZeros
  , cmp "==" (==)
  , cmp "/=" (/=)
  , cmp "<"  (<)
  , cmp "<=" (<=)
  , cmp ">"  (>)
  , cmp ">=" (>=)
  , cmpw "u<"  (<)
  , cmpw "u<=" (<=)
  , cmpw "u>"  (>)
  , cmpw "u>=" (>=)
  , comb "icmp" (\ x y -> fromOrdering (compare (x::Int) y))
  , comb "ucmp" (\ x y -> fromOrdering (compare (x::Word) y))

  , arithI "I+" (+)
  , arithI "I-" (-)
  , arithI "I*" (*)
  , arithI "Iquot" quot
  , arithI "Irem" rem
  , arithI "Isubtract" subtract
  , arithuI "Ineg" negate
  , arithuI "Iinv" complement
  , arithwI "Iuquot" quot
  , arithwI "Iurem" rem
  , arithwI "Iand" (.&.)
  , arithwI "Ior" (.|.)
  , arithwI "Ixor" xor
  , arithwiI "Ishl" shiftL
  , arithwiI "Ishr" shiftR
  , arithwiI "Iashr" shiftR
  , arithuiI "Ipopcount" popCount
  , arithuiI "Iclz" countLeadingZeros
  , arithuiI "Ictz" countTrailingZeros
  , cmpI "I==" (==)
  , cmpI "I/=" (/=)
  , cmpI "I<"  (<)
  , cmpI "I<=" (<=)
  , cmpI "I>"  (>)
  , cmpI "I>=" (>=)
  , cmpwI "Iu<"  (<)
  , cmpwI "Iu<=" (<=)
  , cmpwI "Iu>"  (>)
  , cmpwI "Iu>=" (>=)
  , comb "Iicmp" (\ x y -> fromOrdering (compare (x::Int64) y))
  , comb "Iucmp" (\ x y -> fromOrdering (compare (x::Word64) y))

  , comb "itoI" (\ x -> fromIntegral (x::Int) :: Int64)
  , comb "Itoi" (\ x -> fromIntegral (x::Int64) :: Int)
  , comb "utoU" (\ x -> fromIntegral (x::Word) :: Word64)
  , comb "Utou" (\ x -> fromIntegral (x::Word64) :: Word)

  , comb "fp2p" unsafeForeignPtrToPtr

  , comb "A.alloc" newIOArray
  , comb "A.size" sizeIOArray
  , comb "A.read" readIOArray
  , comb "A.write" writeIOArray
--  , comb "A.==" eqIOArray

  , farith "f+" (+)
  , farith "f-" (-)
  , farith "f*" (*)
  , farith "f/" (/)
  , farithu "fneg" negate
  , fcmp "f==" (==)
  , fcmp "f/=" (/=)
  , fcmp "f<" (<)
  , fcmp "f<=" (<=)
  , fcmp "f>" (>)
  , fcmp "f>=" (>=)
  , comb "itof" (fromIntegral :: Int -> Float)

  , darith "d+" (+)
  , darith "d-" (-)
  , darith "d*" (*)
  , darith "d/" (/)
  , darithu "dneg" negate
  , dcmp "d==" (==)
  , dcmp "d/=" (/=)
  , dcmp "d<" (<)
  , dcmp "d<=" (<=)
  , dcmp "d>" (>)
  , dcmp "d>=" (>=)
  , comb "itod" (fromIntegral :: Int -> Double)

  , comb "seq" seq
  , comb "rnf" rnf
  , comb "ord" ord
  , comb "chr" chr

  , comb "IO.performIO" unsafePerformIO
  , comb "IO.>>=" iobind
  , comb "IO.>>" iothen
  , comb "IO.return" ioret
  , comb "IO.print" ioprint
  , comb "IO.serialize" ioserialize
  , comb "IO.deserialize" iodeserialize
  , comb "newCAStringLen" (fmap fromPair . newCAStringLen . toString)
  , comb "IO.getArgRef" iogetargref

  , comb0 "IO.stdin" stdin
  , comb0 "IO.stdout" stdout
  , comb0 "IO.stderr" stderr

  ]
  where
    comb0 n f = (n, unsafeCoerce f)
    comb n f = (n, unsafeCoerce f)
--    comb n f = (n, unsafeCoerce (\ x -> trace (seq x n) (f x)))

    arith :: String -> (Int -> Int -> Int) -> (String, Any)
    arith = comb
    arithw :: String -> (Word -> Word -> Word) -> (String, Any)
    arithw = comb
    arithwi :: String -> (Word -> Int -> Word) -> (String, Any)
    arithwi = comb
    arithu :: String -> (Int -> Int) -> (String, Any)
    arithu = comb

    arithI :: String -> (Int64 -> Int64 -> Int64) -> (String, Any)
    arithI = comb
    arithwI :: String -> (Word64 -> Word64 -> Word64) -> (String, Any)
    arithwI = comb
    arithwiI :: String -> (Word64 -> Int -> Word64) -> (String, Any)
    arithwiI = comb
    arithuI :: String -> (Int64 -> Int64) -> (String, Any)
    arithuI = comb
    arithuiI :: String -> (Int64 -> Int) -> (String, Any)
    arithuiI = comb

    farith :: String -> (Float -> Float -> Float) -> (String, Any)
    farith = comb
    farithu :: String -> (Float -> Float) -> (String, Any)
    farithu = comb

    darith :: String -> (Double -> Double -> Double) -> (String, Any)
    darith = comb
    darithu :: String -> (Double -> Double) -> (String, Any)
    darithu = comb

    cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
    cmp n f = comb n (\ x y -> fromBool (f x y))
    cmpw :: String -> (Word -> Word -> Bool) -> (String, Any)
    cmpw n f = comb n (\ x y -> fromBool (f x y))

    cmpI :: String -> (Int64 -> Int64 -> Bool) -> (String, Any)
    cmpI n f = comb n (\ x y -> fromBool (f x y))
    cmpwI :: String -> (Word64 -> Word64 -> Bool) -> (String, Any)
    cmpwI n f = comb n (\ x y -> fromBool (f x y))

    fcmp :: String -> (Float -> Float -> Bool) -> (String, Any)
    fcmp n f = comb n (\ x y -> fromBool (f x y))
    dcmp :: String -> (Double -> Double -> Bool) -> (String, Any)
    dcmp n f = comb n (\ x y -> fromBool (f x y))

    iobind :: IO a -> (a -> IO b) -> IO b
    iobind = (>>=)
    iothen :: IO a -> IO b -> IO b
    iothen = (>>)
    ioret :: a -> IO a
    ioret = return
    -- Can't implement this
    ioprint :: Handle -> a -> IO ()
    ioprint h _ = hPutStrLn h "ghc does not support cprint"
    ioserialize :: Handle -> a -> IO ()
    ioserialize h _ = hPutStrLn h "ghc does not support serialize"
    iodeserialize :: Handle -> IO a
    iodeserialize _ = error "ghc does not support deserialize"

{-
    iogetargs :: IO Any
    iogetargs = do
      args <- getArgs
      return $ fromList $ map fromString args
-}
    iogetargref = error "ghc: no IO.getArgRef"

    -- Can't implement this
    rnf :: a -> ()
    rnf x = seq x ()

    newIOArray :: Int -> a -> IO (IOArr a)
    newIOArray i arr = newArray (0, i-1) arr
    sizeIOArray :: IOArr a -> IO Int
    sizeIOArray arr = pred . snd <$> getBounds arr
    readIOArray :: IOArr a -> Int -> IO a
    readIOArray arr i = readArray arr i
    writeIOArray :: IOArr a -> Int -> a -> IO ()
    writeIOArray arr i a = writeArray arr i a
--    eqIOArray :: IOArr a -> IOArr a -> IO Bool


fromBool :: Bool -> Any
fromBool False = unsafeCoerce const
fromBool True  = unsafeCoerce $ \ _x y -> y

fromOrdering :: Ordering -> (Any -> Any -> Any -> Any)
fromOrdering LT = \ x _y _z -> x
fromOrdering EQ = \ _x y _z -> y
fromOrdering GT = \ _x _y z -> z

fromPair :: (a, b) -> Any
fromPair (x, y) = unsafeCoerce $ \ pair -> pair x y

fromString :: String -> Any
fromString = fromList . map (unsafeCoerce . ord)

fromList :: [Any] -> Any
fromList [] = unsafeCoerce const
fromList (x:xs) = unsafeCoerce $ \ _nil cons -> cons (unsafeCoerce x) (fromList xs)

toList :: Any -> [Int]
toList a = unsafeCoerce a [] (\ i is -> i : toList is)

toString :: Any -> String
toString = map chr . toList

dynsym :: Any -> Any
dynsym acfun =
  let s = toString acfun
  in
--      trace ("dynsym: " ++ show s) $
      fromMaybe (error $ "ghc: unimplemented FFI: " ++ s) $ lookup s cops

cops :: [(String, Any)]
cops =
  [ comb "getTimeMilli" getTimeMilli
  , comb "fputc" fputc
  , comb "fgetc" fgetc
  , comb "fopen" fopen
  , comb "fclose" fclose
  , comb "putb"  putb
  , comb "add_FILE" add_FILE
  , comb "add_utf8" add_utf8
  , comb "free"  free
  , comb "exp"   (dio exp)
  , comb "log"   (dio log)
  , comb "sqrt"   (dio sqrt)
  , comb "sin"   (dio sin)
  , comb "cos"   (dio cos)
  , comb "tan"   (dio tan)
  , comb "asin"   (dio asin)
  , comb "acos"   (dio acos)
  , comb "atan"   (dio atan)
  , comb "sinh"   (dio sinh)
  , comb "cosh"   (dio cosh)
  , comb "tanh"   (dio tanh)
  , comb "asinh"   (dio asinh)
  , comb "acosh"   (dio acosh)
  , comb "atanh"   (dio atanh)
  , comb "atan2"   (dio2 atan2)
  , comb "expf"   (fio exp)
  , comb "logf"   (fio log)
  , comb "sqrtf"   (fio sqrt)
  , comb "sinf"   (fio sin)
  , comb "cosf"   (fio cos)
  , comb "tanf"   (fio tan)
  , comb "asinf"   (fio asin)
  , comb "acosf"   (fio acos)
  , comb "atanf"   (fio atan)
  , comb "sinhf"   (fio sinh)
  , comb "coshf"   (fio cosh)
  , comb "tanhf"   (fio tanh)
  , comb "asinhf"   (fio asinh)
  , comb "acoshf"   (fio acosh)
  , comb "atanhf"   (fio atanh)
  , comb "atan2f"   (fio2 atan2)
  ]
  where
    comb n f = (n, unsafeCoerce f)

    dio :: (Double -> Double) -> (Double -> IO Double)
    dio f = return . f

    dio2 :: (Double -> Double -> Double) -> (Double -> Double -> IO Double)
    dio2 f x y = return (f x y)

    fio :: (Float -> Float) -> (Float -> IO Float)
    fio f = return . f

    fio2 :: (Float -> Float -> Float) -> (Float -> Float -> IO Float)
    fio2 f x y = return (f x y)

    add_FILE :: Handle -> IO Handle
    add_FILE h = return h

    add_utf8 :: Handle -> IO Handle
    add_utf8 h = do hSetEncoding h utf8; return h

    putb :: Int -> Handle -> IO ()
    putb c h = hPutChar h (chr c)

    fputc :: Int -> Handle -> IO Int
    fputc c h = hPutChar h (chr c) >> return 0

    fgetc :: Handle -> IO Int
    fgetc h = handle (\ (_ :: SomeException) -> return (-1)) (do c <- hGetChar h; return (ord c))

    fopen :: Ptr CChar -> Ptr CChar -> IO Handle
    fopen name mode = do
      sname <- peekCAString name
      smode <- peekCAString mode
      let hmode =
            case smode of
              "r" -> ReadMode
              "w" -> WriteMode
              "a" -> AppendMode
              "w+" -> ReadWriteMode
              _ -> error "fopen"
      openFile sname hmode

    fclose :: Handle -> IO Int
    fclose h = do hClose h; return 0