PrimTable.hs

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

type AnyType = Any

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" (\ x _y -> x)
  , comb "I" (\ x -> x)
  , 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 "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)

  , 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
  , cmp "==" (==)
  , cmp "/=" (/=)
  , cmp "<"  (<)
  , cmp "<=" (<=)
  , cmp ">"  (>)
  , cmp ">=" (>=)
  , cmpw "u<"  (<)
  , cmpw "u<=" (<=)
  , cmpw "u>"  (>)
  , cmpw "u>=" (>=)
  , comb "icmp" (\ x y -> fromOrdering (compare (x::Int) y))

  , comb "scmp" (\ x y -> fromOrdering (compare (toString x) (toString y)))
  , comb "sequal" (\ x y -> fromBool (toString x == toString y))

  , comb "p==" (\ x y -> fromBool ((x :: Ptr ()) == y))
  , comb "pnull" nullPtr
  , comb "pcast" castPtr
  , comb "p+" plusPtr
  , comb "p-" minusPtr

  , farith "f+" (+)
  , farith "f-" (-)
  , farith "f*" (*)
  , farith "f/" (/)
  , farithu "fneg" negate
  , fcmp "f==" (==)
  , fcmp "f/=" (/=)
  , fcmp "f<" (<)
  , fcmp "f<=" (<=)
  , fcmp "f>" (>)
  , fcmp "f>=" (>=)
  , comb "fshow" (fromString . (show :: Double -> String))
  , comb "fread" ((read :: String -> Double) . toString)
  , comb "itof" (fromIntegral :: Int -> Double)

  , comb "seq" seq
  , comb "rnf" rnf
  , comb "error" err
  , comb "ord" ord
  , comb "chr" chr

  , comb "IO.performIO" unsafePerformIO
  , comb "IO.catch" (\ io hdl -> catch (io :: IO Any) (\ (exn :: SomeException) -> hdl (fromString $ takeWhile (/= '\n') $ show exn) :: IO Any))
  , comb "IO.>>=" iobind
  , comb "IO.>>" iothen
  , comb "IO.return" ioret
  , comb "IO.print" ioprint
  , comb "IO.performio" unsafePerformIO
  , comb "IO.serialize" ioserialize
  , comb "IO.deserialize" iodeserialize
  , comb "newCAStringLen" (fmap fromPair . newCAStringLen . toString)
  , comb "IO.getArgs" iogetargs

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

  , comb "noMatch" (\ (s::Any) (l::Int) (c::Int) -> error ("no match at " ++ toString s ++ " line " ++ show l ++ ", col " ++ show c))
  , comb "noDefault" (\ (s::Any) -> error ("no default for " ++ toString s))

  ]
  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
    farith :: String -> (Double -> Double -> Double) -> (String, Any)
    farith = comb
    farithu :: String -> (Double -> Double) -> (String, Any)
    farithu = 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))
    fcmp :: String -> (Double -> Double -> Bool) -> (String, Any)
    fcmp n f = comb n (\ x y -> fromBool (f x y))

    err s = error $ "error: " ++ toString s

    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 "no IO.print"
    ioserialize :: Handle -> a -> IO ()
    ioserialize h _ = hPutStrLn h "no IO.serialize"
    iodeserialize :: Handle -> IO a
    iodeserialize _ = error "iodeserialize"

    iogetargs :: IO Any
    iogetargs = do
      args <- getArgs
      return $ fromList $ map fromString args

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

fromBool :: Bool -> Any
fromBool False = unsafeCoerce $ \ x _y -> x
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 $ \ nil _cons -> nil
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 $ "cops: " ++ s) $ lookup s cops

cops :: [(String, Any)]
cops =
  [ comb "fputc" fputc
  , comb "getTimeMilli" getTimeMilli
  , comb "fgetc" fgetc
  , comb "fopen" fopen
  , comb "fclose" fclose
  , comb "free"  free
  , comb "exp"   (fio exp)
  , comb "log"   (fio log)
  , comb "sqrt"   (fio sqrt)
  , comb "sin"   (fio sin)
  , comb "cos"   (fio cos)
  , comb "tan"   (fio tan)
  , comb "asin"   (fio asin)
  , comb "acos"   (fio acos)
  , comb "atan"   (fio atan)
  , comb "sinh"   (fio sinh)
  , comb "cosh"   (fio cosh)
  , comb "tanh"   (fio tanh)
  , comb "asinh"   (fio asinh)
  , comb "acosh"   (fio acosh)
  , comb "atanh"   (fio atanh)
  , comb "atan2"   (fio2 atan2)
  ]
  where
    comb n f = (n, unsafeCoerce f)

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

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

    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