-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Debugging facilities, in particular to analyze the internal structure of
-- a 'SEXP' as structured JSON.
--
-- This module is intended to be imported qualified.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Language.R.Debug
  ( inspect )
  where

import Control.Memory.Region (V)
import qualified Data.Vector.SEXP as Vector
import qualified Foreign.R as R
import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE, SEXPInfo)
import Foreign.R.Type (IsVector)
import Foreign.Storable
import Language.R.Globals as H
import Language.R.HExp

import Data.Complex
import System.IO.Unsafe ( unsafePerformIO )

import Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy.Char8 as LBS

instance ToJSON SEXPTYPE where
  toJSON :: SEXPTYPE -> Value
toJSON = Text -> Value
A.String (Text -> Value) -> (SEXPTYPE -> Text) -> SEXPTYPE -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (SEXPTYPE -> String) -> SEXPTYPE -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SEXPTYPE -> String
forall a. Show a => a -> String
show

instance ToJSON SEXPInfo where
  toJSON :: SEXPInfo -> Value
toJSON x :: SEXPInfo
x =
    [Pair] -> Value
object
      [ "type"  Text -> SEXPTYPE -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> SEXPTYPE
R.infoType SEXPInfo
x
      , "obj"   Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Bool
R.infoObj SEXPInfo
x
      , "named" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Int
R.infoNamed SEXPInfo
x
      , "gp"    Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Int
R.infoGp SEXPInfo
x
      , "mark"  Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Bool
R.infoMark SEXPInfo
x
      , "debug" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Bool
R.infoDebug SEXPInfo
x
      , "trace" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Bool
R.infoTrace SEXPInfo
x
      , "spare" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Bool
R.infoSpare SEXPInfo
x
      , "gcgen" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Int
R.infoGcGen SEXPInfo
x
      , "gccls" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo -> Int
R.infoGcCls SEXPInfo
x
      ]

instance ToJSON a => ToJSON (Complex a) where
  toJSON :: Complex a -> Value
toJSON (x :: a
x :+ y :: a
y) =
    [Pair] -> Value
object ["Re" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
x, "Im" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
y]

instance ToJSON (SEXP s a) where
  toJSON :: SEXP s a -> Value
toJSON x :: SEXP s a
x =
      [Pair] -> Value
object
        [ "header" Text -> SEXPInfo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXPInfo
info
        , "attributes" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= if SEXP s a -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s a
x SEXP0 -> SEXP0 -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP s Any -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s Any
attr then "loop" else SEXP s Any -> Value
forall a. ToJSON a => a -> Value
toJSON SEXP s Any
attr
        , Text
tp Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a -> Value
forall s (a :: SEXPTYPE). SEXP s a -> Value
go SEXP s a
x
        ]
    where
      vector :: (IsVector a, ToJSON (Vector.ElemRep V a), Storable (Vector.ElemRep V a))
             => Vector.Vector a (Vector.ElemRep V a) -> V.Vector Value
      vector :: Vector a (ElemRep V a) -> Vector Value
vector = [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList ([Value] -> Vector Value)
-> (Vector a (ElemRep V a) -> [Value])
-> Vector a (ElemRep V a)
-> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ElemRep V a -> Value) -> [ElemRep V a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ElemRep V a -> Value
forall a. ToJSON a => a -> Value
toJSON ([ElemRep V a] -> [Value])
-> (Vector a (ElemRep V a) -> [ElemRep V a])
-> Vector a (ElemRep V a)
-> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a (ElemRep V a) -> [ElemRep V a]
forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
Vector.toList -- XXX: do not use lists
      ub :: SEXP0
ub = SEXP G 'Symbol -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP G 'Symbol
H.unboundValue
      nil :: SEXP0
nil = SEXP G 'Nil -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP G 'Nil
H.nilValue
      miss :: SEXP0
miss = SEXP G 'Symbol -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP G 'Symbol
H.missingArg
      info :: SEXPInfo
info = IO SEXPInfo -> SEXPInfo
forall a. IO a -> a
unsafePerformIO (IO SEXPInfo -> SEXPInfo) -> IO SEXPInfo -> SEXPInfo
forall a b. (a -> b) -> a -> b
$ SEXP s a -> IO SEXPInfo
forall s (a :: SEXPTYPE). SEXP s a -> IO SEXPInfo
R.peekInfo SEXP s a
x
      attr :: SEXP s Any
attr = IO (SEXP s Any) -> SEXP s Any
forall a. IO a -> a
unsafePerformIO (IO (SEXP s Any) -> SEXP s Any) -> IO (SEXP s Any) -> SEXP s Any
forall a b. (a -> b) -> a -> b
$ SEXP s a -> IO (SEXP s Any)
forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> IO (SEXP s b)
R.getAttributes SEXP s a
x
      tp :: Text
tp = String -> Text
T.pack (String -> Text) -> (SEXPTYPE -> String) -> SEXPTYPE -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SEXPTYPE -> String
forall a. Show a => a -> String
show (SEXPTYPE -> Text) -> SEXPTYPE -> Text
forall a b. (a -> b) -> a -> b
$ SEXPInfo -> SEXPTYPE
R.infoType SEXPInfo
info
      go :: SEXP s a -> Value
      go :: SEXP s a -> Value
go y :: SEXP s a
y | SEXP s a -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s a
y SEXP0 -> SEXP0 -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP0
ub   = Text -> Value
A.String "UnboundValue"
           | SEXP s a -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s a
y SEXP0 -> SEXP0 -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP0
nil  = Text -> Value
A.String "NilValue"
           | SEXP s a -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s a
y SEXP0 -> SEXP0 -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP0
miss = Text -> Value
A.String "MissingArg"
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> HExp s a
Nil) = Text -> Value
A.String "NilValue"
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Lang i :: SEXP s a
i j :: SEXP s b
j) =
          [Pair] -> Value
object [ "function" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
i
                 , "parameters" Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
j
                 ]
      go h :: SEXP s a
h@(SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Symbol i :: SEXP s a
i j :: SEXP s b
j k :: SEXP s c
k) =
          [Pair] -> Value
object [ "name" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
i
                 , "value" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= if SEXP s b -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s b
j SEXP0 -> SEXP0 -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP s a -> SEXP0
forall s (a :: SEXPTYPE). SEXP s a -> SEXP0
R.unsexp SEXP s a
h then "loop" else SEXP s b -> Value
forall a. ToJSON a => a -> Value
toJSON SEXP s b
j
                 , "internal" Text -> SEXP s c -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s c
k
                 ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Special i :: Int32
i) = [Pair] -> Value
object ["index" Text -> Int32 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int32
i]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Builtin i :: Int32
i) = [Pair] -> Value
object ["index" Text -> Int32 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int32
i]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Char v :: Vector 'Char Word8
v) = Text -> Value
A.String (String -> Text
T.pack (Vector 'Char Word8 -> String
Vector.toString Vector 'Char Word8
v))
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Int v :: Vector 'Int Int32
v) = Vector Value -> Value
A.Array (Vector 'Int (ElemRep V 'Int) -> Vector Value
forall (a :: SEXPTYPE).
(IsVector a, ToJSON (ElemRep V a), Storable (ElemRep V a)) =>
Vector a (ElemRep V a) -> Vector Value
vector Vector 'Int Int32
Vector 'Int (ElemRep V 'Int)
v)
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Real v :: Vector 'Real Double
v) = Vector Value -> Value
A.Array (Vector 'Real (ElemRep V 'Real) -> Vector Value
forall (a :: SEXPTYPE).
(IsVector a, ToJSON (ElemRep V a), Storable (ElemRep V a)) =>
Vector a (ElemRep V a) -> Vector Value
vector Vector 'Real Double
Vector 'Real (ElemRep V 'Real)
v)
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Complex v :: Vector 'Complex (Complex Double)
v) = Vector Value -> Value
A.Array (Vector 'Complex (ElemRep V 'Complex) -> Vector Value
forall (a :: SEXPTYPE).
(IsVector a, ToJSON (ElemRep V a), Storable (ElemRep V a)) =>
Vector a (ElemRep V a) -> Vector Value
vector Vector 'Complex (Complex Double)
Vector 'Complex (ElemRep V 'Complex)
v)
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Vector _ v :: Vector 'Vector (SomeSEXP V)
v) = Vector Value -> Value
A.Array (Vector 'Vector (ElemRep V 'Vector) -> Vector Value
forall (a :: SEXPTYPE).
(IsVector a, ToJSON (ElemRep V a), Storable (ElemRep V a)) =>
Vector a (ElemRep V a) -> Vector Value
vector Vector 'Vector (SomeSEXP V)
Vector 'Vector (ElemRep V 'Vector)
v)
--  String    :: {-# UNPACK #-} !(Vector.Vector (SEXP (R.Vector Word8)))
--            -> HExp (R.Vector (SEXP (R.Vector Word8)))
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> List i :: SEXP s a
i j :: SEXP s b
j k :: SEXP s c
k) =
          [Pair] -> Value
object [ "value" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
i
                 , "next"  Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
j
                 , "tag"   Text -> SEXP s c -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s c
k
                 ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Env _ _ _) = Text -> Value
A.String "Environment"
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Closure f :: SEXP s a
f b :: SEXP s b
b e :: SEXP s 'Env
e) =
         [Pair] -> Value
object [ "formals" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
f
                , "body" Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
b
                , "environment" Text -> SEXP s 'Env -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s 'Env
e
                ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Promise vl :: SEXP s a
vl ex :: SEXP s b
ex en :: SEXP s c
en) =
          [Pair] -> Value
object [ "value" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
vl
                 , "expr" Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
ex
                 , "environment" Text -> SEXP s c -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s c
en
                 ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> DotDotDot v :: SEXP s a
v) =
          [Pair] -> Value
object [ "promises" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
v]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Expr _ v :: Vector 'Expr (SomeSEXP V)
v)   = Vector Value -> Value
A.Array (Vector 'Expr (ElemRep V 'Expr) -> Vector Value
forall (a :: SEXPTYPE).
(IsVector a, ToJSON (ElemRep V a), Storable (ElemRep V a)) =>
Vector a (ElemRep V a) -> Vector Value
vector Vector 'Expr (SomeSEXP V)
Vector 'Expr (ElemRep V 'Expr)
v)
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> HExp s a
Bytecode) = Text -> Value
A.String "Bytecode"
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> ExtPtr _ a :: SEXP s b
a b :: SEXP s 'Symbol
b) =
          [Pair] -> Value
object [ "ptr" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
A.String "<PTR>"
                 , "second" Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
a
                 , "symbol" Text -> SEXP s 'Symbol -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s 'Symbol
b
                 ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> WeakRef k :: SEXP s a
k v :: SEXP s b
v fn :: SEXP s c
fn nxt :: SEXP s d
nxt) =
          [Pair] -> Value
object [ "key" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
k
                 , "value" Text -> SEXP s b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s b
v
                 , "finalizer" Text -> SEXP s c -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s c
fn
                 , "next" Text -> SEXP s d -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s d
nxt
                 ]
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> Raw _bs :: Vector 'Raw Word8
_bs) = Text -> Value
A.String "<data>"
      go (SEXP s a -> HExp s a
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
hexp -> S4 s :: SEXP s a
s) =
          [Pair] -> Value
object [ "tagval" Text -> SEXP s a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SEXP s a
s ]
      go _ = Text -> Value
A.String "Unimplemented."

instance ToJSON (SomeSEXP s) where
  toJSON :: SomeSEXP s -> Value
toJSON (R.SomeSEXP s :: SEXP s a
s) = SEXP s a -> Value
forall a. ToJSON a => a -> Value
toJSON SEXP s a
s

inspect :: SEXP s a -> String
inspect :: SEXP s a -> String
inspect = ByteString -> String
LBS.unpack (ByteString -> String)
-> (SEXP s a -> ByteString) -> SEXP s a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SEXP s a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode