module Debug.DebugTrace(
DebugTrace(..),
Function(..),
CallData(..),
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()
import Web.Browser
import Paths_debug
import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>), (<>))
import Prelude
data Function = Function
{funName :: Text
,funSource :: Text
,funArguments :: [Text]
,funResult :: Text
}
deriving (Eq,Generic,Ord,Show)
instance Hashable Function
instance NFData Function
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 ]
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 :: 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
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
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
instance Show a where
show _ = "?"
#endif
debugJSONTrace :: DebugTrace -> B.ByteString
debugJSONTrace = encode
data DebugTrace = DebugTrace
{ functions :: [Function]
, variables :: [Text]
, calls :: [CallData]
}
deriving (Eq, Generic, Show)
instance FromJSON DebugTrace
instance ToJSON DebugTrace where
toEncoding = genericToEncoding defaultOptions
instance NFData DebugTrace
data CallData = CallData
{ callFunctionId :: Int
, callVals :: [(Text, Int)]
, callDepends :: [Int]
, callParents :: [Int]
}
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