{-# OPTIONS_GHC -ffi #-}
{-------------------------------------------------------------------------------

        Module:                 ReifyHs

        Description:            turn haskell values into meta representations of
                                them.

                                reify :: a -> IO Graph

                                The Graph type captures cycles, thunks and
                                all data types, but not functions.

        Primary Authors:        Bernie Pope

                                Relies on GHC and ReifyC.c, GhcInternalsC.c
                                                  HeapGraph.c

-------------------------------------------------------------------------------}

module ReifyHs ( reify
               , Graph (..)
               , GraphKind (..)
               , graphKind
               , tagToKind
               , graphIsList
               , graphIsTuple
               ) where

import Foreign
   ( StablePtr
   , newStablePtr
   , deRefStablePtr
   , freeStablePtr )

import System.IO.Unsafe
   ( unsafePerformIO )

type Unique = Int
type Tag = Int
type NumKids = Int

-- mirrors the type GraphNode in Internals.h
data Graph
   = AppNode Unique String Tag NumKids [Graph]
   | CharNode Char
   | IntNode Int
   | IntegerNode Integer
   | FloatNode Float
   | DoubleNode Double
   | NullNode
   deriving Show

instance Eq Graph where
   -- ignore the unique number (memory address)
   (AppNode _u1 str1 tag1 num1 gs1) == (AppNode _u2 str2 tag2 num2 gs2)
      = str1 == str2 && num1 == num2 && tag1 == tag2 && gs1 == gs2
   (CharNode c1) == (CharNode c2) = c1 == c2
   (IntNode i1) == (IntNode i2) = i1 == i2
   (IntegerNode i1) == (IntegerNode i2) = i1 == i2
   (FloatNode f1) == (FloatNode f2) = f1 == f2
   (DoubleNode d1) == (DoubleNode d2) = d1 == d2
   NullNode == NullNode = True
   _ == _ = False

-- predicates to say what kind of thing the graph is

data GraphKind
   = GNode
   | GCycle
   | GThunk
   | GChar
   | GInt
   | GInteger
   | GFloat
   | GDouble
   | GException
   | GApUpd
   | GFun
   | GNull
   deriving (Eq, Show)

graphKind :: Graph -> GraphKind
graphKind (AppNode _ _ tag _ _) = tagToKind tag
graphKind (CharNode _) = GChar
graphKind (IntNode _) = GInt
graphKind (IntegerNode _) = GInteger
graphKind (FloatNode _) = GFloat
graphKind (DoubleNode _) = GDouble
graphKind NullNode = GNull

-- this MUST be in sync with Internals.h
tagToKind :: Tag -> GraphKind
tagToKind 1 = GNode
tagToKind 2 = GCycle
tagToKind 3 = GThunk
tagToKind 4 = GChar
tagToKind 5 = GInt
tagToKind 6 = GInteger -- 6 is a small integer 7 is a large one!
tagToKind 7 = GInteger
tagToKind 8 = GFloat
tagToKind 9 = GDouble
tagToKind 10 = GException
tagToKind 11 = GApUpd
tagToKind 12 = GFun
tagToKind 13 = GNull

-- true if the graph represents a list
graphIsList :: Graph -> Bool
graphIsList (AppNode _unique "[]" _tag _numKids _kids) = True
graphIsList (AppNode _unique ":" _tag _numKids _kids)  = True
graphIsList other = False

-- true if the graph represents a n-tuple
-- "(,)", "(,,)", ...
graphIsTuple :: Graph -> Bool
graphIsTuple (AppNode _unique desc _tag _numKids _kids)
   = isTupleDesc desc
   where
   isTupleDesc :: String -> Bool
   isTupleDesc [] = False
   isTupleDesc [_] = False
   isTupleDesc [_,_] = False
   isTupleDesc ('(':tail)
      = isTupleDesc' tail
      where
      isTupleDesc' :: String -> Bool
      isTupleDesc' [] = False
      isTupleDesc' [_] = False
      isTupleDesc' ",)" = True
      isTupleDesc' (',':x:rest) = isTupleDesc' (x:rest)
      isTupleDesc' other = False
   isTupleDesc other = False
graphIsTuple other = False

{- interface to C -}

type AppNodeType = Int -> String -> Int -> Int -> [Graph] -> Graph

foreign import ccall "reifyC"
               reifyC :: StablePtr a                             -- the value to be inspected
                      -> StablePtr AppNodeType                   -- AppNode
                      -> StablePtr (Char -> Graph)               -- Char
                      -> StablePtr (Int -> Graph)                -- Int
                      -> StablePtr (Integer -> Graph)            -- Integer
                      -> StablePtr (Float -> Graph)              -- Float
                      -> StablePtr (Double -> Graph)             -- Double
                      -> StablePtr Graph                         -- Null
                      -> StablePtr [Graph]                       -- Nil
                      -> StablePtr (Graph -> [Graph] -> [Graph]) -- Cons
                      -> IO (StablePtr Graph)                    -- result

{-# NOINLINE sptrAppNode #-}
sptrAppNode :: StablePtr AppNodeType
sptrAppNode = unsafePerformIO $ newStablePtr AppNode

{-# NOINLINE sptrChar #-}
sptrChar :: StablePtr (Char -> Graph)
sptrChar = unsafePerformIO $ newStablePtr CharNode

{-# NOINLINE sptrInt #-}
sptrInt :: StablePtr (Int -> Graph)
sptrInt = unsafePerformIO $ newStablePtr IntNode

{-# NOINLINE sptrInteger #-}
sptrInteger :: StablePtr (Integer -> Graph)
sptrInteger = unsafePerformIO $ newStablePtr IntegerNode

{-# NOINLINE sptrFloat #-}
sptrFloat :: StablePtr (Float -> Graph)
sptrFloat = unsafePerformIO $ newStablePtr FloatNode

{-# NOINLINE sptrDouble #-}
sptrDouble :: StablePtr (Double -> Graph)
sptrDouble = unsafePerformIO $ newStablePtr DoubleNode

{-# NOINLINE sptrNull #-}
sptrNull :: StablePtr Graph
sptrNull = unsafePerformIO $ newStablePtr NullNode

{-# NOINLINE sptrNil #-}
sptrNil :: StablePtr [Graph]
sptrNil = unsafePerformIO $ newStablePtr ([] :: [Graph])

{-# NOINLINE sptrCons #-}
sptrCons :: StablePtr (Graph -> [Graph] -> [Graph])
sptrCons = unsafePerformIO $ newStablePtr ((:) :: Graph -> [Graph] -> [Graph])

-- package up the whole thing in a nice Haskell interface
reify :: a -> IO Graph
reify x
   = do sptrObj <- newStablePtr x
        sptrGraph <- reifyC sptrObj
                            sptrAppNode
                            sptrChar
                            sptrInt
                            sptrInteger
                            sptrFloat
                            sptrDouble
                            sptrNull
                            sptrNil
                            sptrCons
        graph <- deRefStablePtr sptrGraph
        freeStablePtr sptrGraph
        freeStablePtr sptrObj
        return graph