-- |
-- 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 Data.String (fromString)
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

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

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

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

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

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