DebugTrace.hs

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Dodgy Show instance, useful for debugging
{-# OPTIONS_GHC -Wno-deprecations #-} -- Dodgy Show instance, useful for debugging

-- | Module for recording and manipulating debug traces. For most users, the
--   @TemplateHaskell@ helpers in "Debug" should be sufficient.
module Debug.DebugTrace(
    -- * Debug traces
    DebugTrace(..),
    Function(..),
    CallData(..),
    -- * Viewing the trace
    debugPrintTrace,
    debugJSONTrace,
    debugViewTrace,
    debugSaveTrace,
    getTraceVars
    ) where

import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Aeson
import Data.Aeson.Text
import Data.Aeson.Types
import Data.Char
import Data.Hashable
import Data.List.Extra
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import Data.Text.Read as T
import Data.Tuple.Extra
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Vector as V
import GHC.Generics
import System.IO
import System.Directory
import Text.Show.Functions() -- Make sure the Show for functions instance exists
import Web.Browser
import Paths_debug
import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>), (<>))
import Prelude


-- | Metadata about a function, used to drive the HTML view.
data Function = Function
    {funName :: Text -- ^ Function name
    ,funSource :: Text -- ^ Function source, using @\n@ to break lines
    ,funArguments :: [Text] -- ^ Variables for the arguments to the function
    ,funResult :: Text -- ^ Variable for the result of the function
    }
    deriving (Eq,Generic,Ord,Show)

instance Hashable Function
instance NFData Function

-- | Along with the function metatdata, get a list of the variable names and string values from the trace
getTraceVars :: DebugTrace -> [(Function, [(Text, Text)])]
getTraceVars DebugTrace{..} =
    let lookupFun = (V.fromList functions V.!)
        lookupVar = (V.fromList variables V.!)
    in [ (lookupFun callFunctionId, map (second lookupVar) callVals)
       | CallData{..} <- calls ]

-- | Print information about the observed function calls to 'stdout',
--   in a human-readable format.
debugPrintTrace :: DebugTrace -> IO ()
debugPrintTrace trace@DebugTrace{..} = do
    let concs = getTraceVars trace
    let docs = map call $ nubOrd $ reverse concs
    putDoc (vcat docs <> hardline)
    where
          call :: (Function, [(Text, Text)]) -> Doc
          call (f, vs) =
                   let ass = vs
                       hdr = bold $ header ass f
                   in hang 5 $ hdr <$$> body ass

          header :: [(Text, Text)] -> Function -> Doc
          header ass f = "\n*"       <+>
                         pretty (funName f) <+>
                         arguments ass    <+>
                         "="         <+>
                         result ass

          arguments :: [(Text, Text)] -> Doc
          arguments ass =
                let vals = map snd
                         $ sortOn fst
                         $ mapMaybe (\(t, v) -> (,v) <$> getArgIndex t)
                           ass
                in hsep (map pretty vals)

          result :: [(Text, Text)] -> Doc
          result = pretty . fromMaybe "no result!" . lookup "$result"

          body :: [(Text, Text)] -> Doc
          body svs = vsep $ map bodyLine svs

          bodyLine :: (Text, Text) -> Doc
          bodyLine (t, v) = pretty t <+> "=" <+> pretty v

          -- getArgIndex $arg19 = Just 19
          getArgIndex :: Text -> Maybe Int
          getArgIndex (T.stripPrefix "$arg" -> Just rest) = case T.decimal(T.takeWhile isDigit rest) of Left e -> Nothing ; Right(i,rest) -> Just i
          getArgIndex _ = Nothing

-- | Save information about observed functions to the specified file, in HTML format.
debugSaveTrace :: FilePath -> DebugTrace -> IO ()
debugSaveTrace file db = do
    html  <- TL.readFile =<< getDataFileName "html/debug.html"
    debug <- TL.readFile =<< getDataFileName "html/debug.js"
    css   <- TL.readFile =<< getDataFileName "html/debug.css"
    let trace = encodeToLazyText db
    let script a = "<script>\n" <> a <> "\n</script>"
    let style a = "<style>\n" <> a <> "\n</style>"
    let f x | "trace.js" `TL.isInfixOf` x = script ("var trace =\n" <> trace <> ";")
            | "debug.js" `TL.isInfixOf` x = script debug
            | "debug.css" `TL.isInfixOf` x = style css
            | otherwise = x
    TL.writeFile file $ TL.unlines $ map f $ TL.lines html

-- | Open a web browser showing information about observed functions.
debugViewTrace :: DebugTrace -> IO ()
debugViewTrace db = do
    tdir <- getTemporaryDirectory
    file <- bracket
        (openTempFile tdir "debug.html")
        (hClose . snd)
        (return . fst)
    debugSaveTrace file db
    b <- openBrowser file
    unless b $
        putStrLn $
            "Failed to start a web browser, open: " ++ file ++ "\n" ++
            "In future you may wish to use 'debugSaveTrace."

#if __GLASGOW_HASKELL__ >= 800
-- On older GHC's this level of overlap leads to a compile error

-- | An orphan instance of 'Show' that maps anything without a 'Show' instance
--   to @?@. Suitable for use only when debugging.
instance {-# OVERLAPS #-} Show a where
    show _ = "?"
#endif

---------------------------------
-- Json output

-- | Obtain information about observed functions in JSON format.
--   The JSON format is not considered a stable part of the interface,
--   more presented as a back door to allow exploration of alternative
--   views.
debugJSONTrace :: DebugTrace -> B.ByteString
debugJSONTrace = encode

-- | A flat encoding of debugging observations.
data DebugTrace = DebugTrace
  { functions :: [Function]  -- ^ Flat list of all the functions traced
  , variables :: [Text]    -- ^ Flat list of all the variable values observed
  , calls     :: [CallData]  -- ^ Flat list of all the function calls traced
  }
  deriving (Eq, Generic, Show)

instance FromJSON DebugTrace
instance ToJSON DebugTrace where
  toEncoding = genericToEncoding defaultOptions
instance NFData DebugTrace

-- | A flat encoding of an observed call.
data CallData = CallData
  { callFunctionId :: Int       -- ^ An index into the 'functions' table
  , callVals :: [(Text, Int)] -- ^ The value name tupled with an index into the 'variables' table
  , callDepends :: [Int]        -- ^ Indexes into the 'calls' table
  , callParents :: [Int]        -- ^ Indexes into the 'calls' table
  }
  deriving (Eq, Generic, Show)

instance NFData CallData

instance FromJSON CallData where
  parseJSON (Object v) =
    CallData <$> v .: "" <*> vals <*> (fromMaybe [] <$> (v .:? "$depends")) <*>
    (fromMaybe [] <$> (v .:? "$parents"))
    where
      vals =
        sequence
          [ (k, ) <$> parseJSON x
          | (k, x) <- HM.toList v
          , not (T.null k)
          , k /= "$depends"
          , k /= "$parents"
          ]
  parseJSON invalid = typeMismatch "CallData" invalid

instance ToJSON CallData where
  toJSON CallData {..} =
    object $
    "" .= callFunctionId :
    ["$depends" .= toJSON callDepends | not (null callDepends)] ++
    ["$parents" .= toJSON callParents | not (null callParents)] ++
    map (uncurry (.=)) callVals
  toEncoding CallData {..} =
    pairs
      ("" .= callFunctionId <> depends <> parents <> foldMap (uncurry (.=)) callVals)
    where
      depends
        | null callDepends = mempty
        | otherwise = "$depends" .= callDepends
      parents
        | null callParents = mempty
        | otherwise = "$parents" .= callParents

functionJsonOptions :: Options
functionJsonOptions = defaultOptions{fieldLabelModifier = f}
    where
        f x | Just (x:xs) <- stripPrefix "fun" x = toLower x : xs
            | otherwise = x

instance FromJSON Function where
    parseJSON = genericParseJSON functionJsonOptions

instance ToJSON Function where
    toJSON = genericToJSON functionJsonOptions
    toEncoding = genericToEncoding functionJsonOptions