module Debug.Variables(
debug,
debugClear,
debugRun,
debugPrint,
debugJSON,
debugView,
debugSave,
DebugTrace(..),
getDebugTrace,
funInfo, fun, var,
) where
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Monad.Extra
import Data.Aeson
import Data.Aeson.Text
import Data.Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Generics.Uniplate.Data
import Data.Hashable
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Data.List.Extra
import Data.Maybe
import Data.Monoid ()
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import Data.Text.Read as T
import Data.Tuple.Extra
import qualified Data.Vector as V
import Debug.DebugTrace
import Debug.Util
import GHC.Generics
import GHC.Prim
import GHC.Types
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Directory
import System.IO
import System.IO.Unsafe
import Text.Show.Functions ()
import Unsafe.Coerce
debugRun :: IO a -> IO a
debugRun = bracket_ debugClear debugView
debugPrint :: IO ()
debugPrint = getDebugTrace >>= debugPrintTrace
debugSave :: FilePath -> IO ()
debugSave fp = debugSaveTrace fp =<< getDebugTrace
debugView :: IO ()
debugView = getDebugTrace >>= debugViewTrace
debugJSON :: IO String
debugJSON = B.unpack . debugJSONTrace <$> getDebugTrace
data Call = Call Function (IORef [(Text, Var)])
refVariables :: IORef Variables
refVariables = unsafePerformIO $ newIORef newVariables
refCalls :: IORef [Call]
refCalls = unsafePerformIO $ newIORef []
debugClear :: IO ()
debugClear = do
writeIORef refVariables newVariables
writeIORef refCalls []
getDebugTrace :: IO DebugTrace
getDebugTrace = do
vars <- readIORef refVariables
vars <- return $ map varShow $ listVariables vars
calls <- readIORef refCalls
let infos = nubOrd [x | Call x _ <- calls]
infoId = HM.fromList $ zip infos [0::Int ..]
callEntries <-
forM (reverse calls) $ \(Call info vars) -> do
vars <- readIORef vars
let callFunctionId = infoId HM.! info
callVals = map (second varId) vars
callDepends = []
callParents = []
return CallData{..}
return $ DebugTrace infos (map T.pack vars) callEntries
fun :: Show a => String -> (Call -> a) -> a
fun name = funInfo $ Function (T.pack name) "" [] ""
funInfo :: Show a => Function -> (Call -> a) -> a
funInfo info f = unsafePerformIO $ do
ref <- newIORef []
let x = Call info ref
atomicModifyIORef refCalls $ \v -> (x:v, ())
return $ f x
var :: Show a => Call -> String -> a -> a
var (Call _ ref) name val = unsafePerformIO $ do
when (show val /= "<function>") $ do
var <- atomicModifyIORef refVariables $ addVariable val
name' <- unShadowName ref $ pack name
whenJust name' (\n -> atomicModifyIORef ref $ \v -> ((n, var) :v, ()))
return val
unShadowName :: IORef [(Text, Var)] -> Text -> IO (Maybe Text)
unShadowName ioRef t = do
pairs <- readIORef ioRef
let matches = filter (isPrefixPrime t) $ map fst pairs
let shadowedLimit = 3
if not (null matches)
then do
let lengths = map T.length matches
let zipped = zip matches lengths
let maxLen = maximum lengths
let maxName = fst $ fromJust $ find (\p -> snd p == maxLen) zipped
case length matches of
n | n > shadowedLimit -> return Nothing
_ -> return $ Just $ maxName `T.append` "'"
else return $ Just t
isPrefixPrime :: Text -> Text -> Bool
isPrefixPrime s t = s == T.dropWhileEnd (== '\'') t
debug :: Q [Dec] -> Q [Dec]
debug q = do
missing <- filterM (notM . isExtEnabled) [ViewPatterns, PartialTypeSignatures]
when (missing /= []) $
error $ "\ndebug [d| ... |] requires additional extensions:\n" ++
"{-# LANGUAGE " ++ intercalate ", " (map show missing) ++ " #-}\n"
decs <- q
let askSig x = find (\case SigD y _ -> x == y; _ -> False) decs
mapM (adjustDec askSig) decs
adjustDec :: (Name -> Maybe Dec) -> Dec -> Q Dec
adjustDec askSig x@(SigD name ty@(ForallT vars ctxt typ))
| hasRankNTypes ty = return x
| otherwise = return $
SigD name $ ForallT vars (delete WildCardT ctxt ++ [WildCardT]) typ
adjustDec askSig (SigD name typ) = adjustDec askSig $ SigD name $ ForallT [] [] typ
adjustDec askSig o@(FunD name clauses@(Clause arity _ _:_))
| Just (SigD _ ty) <- askSig name
, hasRankNTypes ty = return o
| otherwise = do
inner <- newName "inner"
tag <- newName "tag"
args <- sequence [newName $ "arg" ++ show i | i <- [1 .. length arity]]
let addTag (Clause ps bod inner) = Clause (VarP tag:ps) bod inner
let clauses2 = map addTag $ transformBi (adjustPat tag) clauses
let args2 = [VarE 'var `AppE` VarE tag `AppE` toLitPre "$" a `AppE` VarE a | a <- args]
let info = ConE 'Function `AppE`
packLit (toLit name) `AppE`
packLit (LitE (StringL $ prettyPrint $ maybeToList (askSig name) ++ [o])) `AppE`
ListE (map (packLit . toLitPre "$") args) `AppE`
packLit (LitE (StringL "$result"))
let body2 = VarE 'var `AppE` VarE tag `AppE` LitE (StringL "$result") `AppE` foldl AppE (VarE inner) (VarE tag : args2)
let body = VarE 'funInfo `AppE` info `AppE` LamE [VarP tag] body2
afterApps <- transformApps tag clauses2
return $ FunD name [Clause (map VarP args) (NormalB body) [FunD inner afterApps]]
adjustDec askSig x = return x
transformApps :: Name -> [Clause] -> Q [Clause]
transformApps tag = mapM (appsFromClause tag)
appsFromClause :: Name -> Clause -> Q Clause
appsFromClause tag cl@(Clause pats body decs) = do
newBody <- appsFromBody tag body
newDecs <- mapM (appsFromDec tag) decs
return $ Clause pats newBody newDecs
appsFromBody :: Name -> Body -> Q Body
appsFromBody _ b@(GuardedB _) = return b
appsFromBody tag (NormalB e) = NormalB <$> appsFromExp tag e
appsFromExp :: Name -> Exp -> Q Exp
appsFromExp tag e@(AppE e1 e2) = do
newE1 <- appsFromExp tag e1
newE2 <- appsFromExp tag e2
adjustApp tag (AppE newE1 newE2)
appsFromExp tag e@(LetE decs exp) = do
newDecs <- traverse (appsFromDec tag) decs
LetE newDecs <$> appsFromExp tag exp
appsFromExp tag e@(InfixE e1May e2 e3May) = do
newE1 <- appsFromExpMay tag e1May
newE2 <- appsFromExp tag e2
newE3 <- appsFromExpMay tag e3May
adjustApp tag (InfixE newE1 newE2 newE3)
appsFromExp tag e@(CaseE exp matches) = do
newExp <- appsFromExp tag exp
newMatches <- traverse (appsFromMatch tag) matches
return $ CaseE newExp newMatches
appsFromExp tag e = return e
appsFromExpMay :: Name -> Maybe Exp -> Q (Maybe Exp)
appsFromExpMay tag Nothing = return Nothing
appsFromExpMay tag (Just e) = sequence $ Just $ appsFromExp tag e
appsFromDec :: Name -> Dec -> Q Dec
appsFromDec tag d@(ValD pat body dec) = do
newBody <- appsFromBody tag body
return $ ValD pat newBody dec
appsFromDec tag d@(FunD name subClauses) =
FunD name <$> traverse (appsFromClause tag) subClauses
appsFromDec _ d = return d
appsFromMatch :: Name -> Match -> Q Match
appsFromMatch tag (Match pat body decs) = do
newBody <- appsFromBody tag body
newDecs <- traverse (appsFromDec tag) decs
return $ Match pat newBody newDecs
adjustApp :: Name -> Exp -> Q Exp
adjustApp tag (AppE e1 e2) = do
let displayName = expDisplayName e1
e1n <- newName displayName
let viewP = ViewP (VarE 'var `AppE` VarE tag `AppE` LitE (StringL displayName)) (VarP e1n)
let result = LetE [ValD viewP (NormalB (AppE e1 e2)) []] (VarE e1n)
return result
adjustApp tag e@(InfixE e1May e2 e3May) = do
let displayName = infixExpDisplayName e2
if displayName == "$"
then return e
else do
let legalInfixVar = mkLegalInfixVar displayName
e2Var <- newName legalInfixVar
let viewP = ViewP (VarE 'var `AppE` VarE tag `AppE` LitE (StringL displayName)) (VarP e2Var)
return $ LetE [ValD viewP (NormalB (InfixE e1May e2 e3May)) []] (VarE e2Var)
adjustApp _ e@(UInfixE e1 e2 e3) = return e
adjustApp _ e = return e
expDisplayName :: Exp -> String
expDisplayName e =
let name = removeLet $ (show . ppr) e
in removeExtraDigits (takeWhileEnd (/= '.') ((head . words) name))
infixExpDisplayName :: Exp -> String
infixExpDisplayName e =
let name = removeLet $ (show . ppr) e
name' = removeExtraDigits (takeWhileEnd (/= '.') ((head . words) name))
in fromMaybe name' $ stripSuffix ")" name'
adjustPat :: Name -> Pat -> Pat
adjustPat tag (VarP x) = ViewP (VarE 'var `AppE` VarE tag `AppE` toLit x) (VarP x)
adjustPat tag x = x
toLit :: Name -> Exp
toLit = toLitPre ""
toLitPre :: String -> Name -> Exp
toLitPre pre (Name (OccName x) _) = LitE $ StringL $ pre ++ x
packLit :: Exp -> Exp
packLit = AppE (VarE 'pack)
data Variables = Variables
Int
[(Any, String)]
data Var = Var Int String
deriving (Eq,Ord)
instance Show Var where
show (Var i s) = s ++ " @" ++ show i
varId :: Var -> Int
varId (Var x _) = x
varShow :: Var -> String
varShow (Var _ x) = x
newVariables :: Variables
newVariables = Variables 0 []
listVariables :: Variables -> [Var]
listVariables (Variables n xs) = [Var i s | (i,(_,s)) <- zipFrom 0 $ reverse xs]
addVariable :: Show a => a -> Variables -> (Variables, Var)
addVariable a vs@(Variables n xs) =
case findIndex (\(key,_) -> ptrEqual key keyA) xs of
Nothing -> (Variables (n+1) ((keyA,showA):xs), Var n showA)
Just i -> (vs, Var (ni1) $ snd $ xs !! i)
where
keyA = unsafeCoerce a
showA = show a
ptrEqual :: Any -> Any -> Bool
ptrEqual a b = unsafePerformIO $ do
a <- evaluate a
b <- evaluate b
return $ isTrue# (reallyUnsafePtrEquality# a b)