debug 0.0.2 → 0.1

raw patch · 19 files changed

+1971/−411 lines, 19 filesdep +Hoeddep +aesondep +bytestringdep −ansi-wl-pprintdep ~basenew-component:exe:debug-ppPVP ok

version bump matches the API change (PVP)

Dependencies added: Hoed, aeson, bytestring, clock, deepseq, filepath, hashable, libgraph, monoidal-containers, prettyprinter, prettyprinter-compat-ansi-wl-pprint, text, unordered-containers, vector, yaml

Dependencies removed: ansi-wl-pprint

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.txt +5/−0
• LICENSE +1/−1
• README.md +104/−9
• debug.cabal +49/−8
• html/debug.html +4/−4
• html/debug.js +80/−20
• src/Debug.hs +2/−108
• src/Debug/DebugTrace.hs +235/−0
• src/Debug/Hoed.hs +419/−0
• src/Debug/Record.hs +0/−208
• src/Debug/Util.hs +64/−0
• src/Debug/Variables.hs +353/−12
• src/DebugPP.hs +271/−0
• test/Hoed.hs +67/−0
• test/Main.hs +5/−41
• test/Util.hs +32/−0
• test/Variables.hs +278/−0
• test/ref/hoed.json +1/−0
• test/ref/hoed80.json +1/−0

@@ -1,5 +1,10 @@ Changelog for Debug +0.1, released 2018-02-16+    Add Hoed based mode+    #16, display values for intermediate function calls+    #8, change the Show desugaring+    #9, make the JSON format external 0.0.2, released 2017-12-18     #6, don't generate context for obviously-monadic things     Make debugPrint a bit nicer

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2017.+Copyright Neil Mitchell 2017-2018. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -12,10 +12,11 @@     where (lt, gt) = partition (<= x) xs ``` -Turn on the `TemplateHaskell` and `ViewPatterns` extensions, import `Debug`, indent your code and place it under a call to `debug`, e.g.:+Turn on the `TemplateHaskell`, `ViewPatterns` and `PartialTypeSignatures` extensions, import `Debug`, indent your code and place it under a call to `debug`, e.g.:  ```haskell-{-# LANGUAGE TemplateHaskell, ViewPatterns #-}+{-# LANGUAGE TemplateHaskell, ViewPatterns, PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-} module QuickSort(quicksort) where import Data.List import Debug@@ -44,14 +45,107 @@  ![Debug view output](debug.png) -## Limitations+You can look and play with the example results for various examples: -This tool is quite new, so it has both limitations, places it is incomplete and bugs. Some notable issues:+* [`quicksort "haskell"`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/output/quicksort.html) as above.+* [`quicksortBy (<) "haskell"`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/output/quicksortBy.html), like `quicksort` but using a comparison function and including a trace of `partition` itself.+* [`lcm_gcd 6 15`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/output/lcm_gcd.html), computing `lcm 6 15 ^^ gcd 6 15`. -* It calls `show` on all the values in encounters, meaning they must all have a `Show` instance (it defines a global `Show` instance which should get used as a fallback), and they will be fully evaluated. If your program relies on laziness it probably won't work.-* It doesn't really understand shadowed variables, so it will work, but the debug results will be lower quality.-* For function values it won't give you a whole lot of information.+## Build tool: `debug-pp` +`debug-pp` is a Haskell source preprocessor for streamlining the `debug` instrumentation of a module or a package. It performs the steps described above automatically. That is:++* append an import for the `Debug` module,+* wrap the body in a `debug` splice using a TH declaration quasiquote, and+* add the required GHC extensions.++To instrument a module, add the following pragma to the top of the file:++```haskell+{-# OPTIONS -F -pgmF debug-pp #-}+```++To instrument an entire program, add the following line to your stack descriptor, or if you don't use stack, to your cabal descriptor:++```haskell+ghc-options: -F -pgmF debug-pp+```++In both cases you will also need to modify your Cabal descriptor in order to++* add a dependency on the `debug` package+* (optional) add a build tool depends on `debug-pp` (required Cabal 2.0) :++```haskell+Library+  ...+  build-tool-depends: debug-pp:debug-pp+```++### Configuration++`debug-pp` tries to find a config file in the following locations (from higher to lower precedence):++1. `.debug-pp.yaml` in the current directory (useful for per-directory+   settings)+2. `.debug-pp.yaml` in the nearest ancestor directory (useful for+   per-project settings)+3. `debug-pp/config.yaml` in the platform’s configuration directory+   (on Windows, it is %APPDATA%, elsewhere it defaults to `~/.config` and+   can be overridden by the `XDG_CONFIG_HOME` environment variable;+   useful for user-wide settings)+4. `.debug-pp.yaml` in your home directory (useful for user-wide+   settings)+5. The default settings.++Use `debug-pp --defaults > .debug-pp.yaml` to dump a+well-documented default configuration to a file, this way you can get started+quickly.++The configuration options include:++* Exclude modules by name.+* Instrument the `main` function with `debugRun`.+* Choice of backend.+* In the case of the `Hoed` backend, whether to enable the automatic deriving of `Generic` and `Observable` instances.++## Debug backends++This package offers two alternative backends for generating the debug trace:++* `import Debug`++   This is the default backend, which relies on `Show` instances to observe values strictly. If your program relies on laziness, it will probably crash or loop.++* `import Debug.Hoed`++   A new experimental backend built on top of [Hoed](https://github.com/MaartenFaddegon/Hoed/pulls). **Requires GHC 8.2 or higher**++   Fully lazy, able to observe function values and provide call stacks: [example](https://rawgit.com/pepeiborra/debug-hoed/master/example/quicksort.html). The instrumentation is simpler, so it is known to work in more cases. It relies on `Observable` instances  which are derivable (the TH wrapper can take care of this automatically). Note that it will probably not work in multi threaded environments yet.++## Requirements++* Polymorphic functions must have type signatures, otherwise GHC will fail to infer an unambiguous type when annotated for debugging.+* Types under observation must have `Show` (or `Observable`) instances, otherwise they will fall back to the default `<?>`.+* Calling the debugged function inside GHCi records the results for viewing inside the UI.++The function can be called multiple times with different parameters, and the results of each+individual run can be selected inside the UI.++## Notes++* You can create multiple `debug [d|...]` blocks inside a module and you can also put more than one function inside a single block.++A function being debugged can refer to another function also being debugged, but due to a limitation+of Template Haskell, the definition of the function being called must occur above the point of its+reference in the source module.++Due to constant applicative forms (CAFs) distorting the debug trace, it is not advisable to run the debugger twice in the same GHCi session.++## Limitations++This tool is quite new, so it has both limitations, places it is incomplete and bugs. Please report all the issues you find and help us make it better.+ ## Alternatives  For practical alternatives for debugging Haskell programs you may wish to consider:@@ -60,7 +154,7 @@ * [Hood](https://hackage.haskell.org/package/hood) and [Hoed](https://hackage.haskell.org/package/Hoed), a value-based observational debugger with a difficult user interface, deals well with laziness. * [Hat](https://hackage.haskell.org/package/hat), good ideas, but I've never got it working. -Compared to the above, `debug` stresses simplicitly of integration and user experience.+Compared to the above, `debug` stresses simplicity of integration and user experience.  ## FAQ @@ -68,5 +162,6 @@  A: If you get `wine: invalid directory "/home/f/.wine" in WINEPREFIX: not an absolute path` when running `debugView` that means `xdg-open` is handled by [Wine](https://www.winehq.org/). Fix that and it will work once more. -+### Q: `debugView` fails with "error: Variable not in scope: debugView"? +A: Explicitly load the Debug module in GHCi via `:m + Debug`

@@ -1,13 +1,13 @@ cabal-version:      >= 1.18 build-type:         Simple name:               debug-version:            0.0.2+version:            0.1 license:            BSD3 license-file:       LICENSE category:           Development, Debugging author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2017+copyright:          Neil Mitchell 2017-2018 synopsis:           Simple trace-based debugger description:     An easy to use debugger for viewing function calls and intermediate variables.@@ -15,7 +15,7 @@     Full usage instructions are at "Debug". homepage:           https://github.com/ndmitchell/debug bug-reports:        https://github.com/ndmitchell/debug/issues-tested-with:        GHC==8.2.1, GHC==8.0.2, GHC==7.10.3+tested-with:        GHC==8.2.2, GHC==8.0.2 extra-doc-files:     CHANGES.txt     README.md@@ -24,6 +24,10 @@     html/debug.html     html/debug.js +extra-source-files:+    test/ref/hoed.json+    test/ref/hoed80.json+ source-repository head     type:     git     location: https://github.com/ndmitchell/debug.git@@ -33,31 +37,68 @@     hs-source-dirs:   src     build-depends:         base == 4.*,+        bytestring,+        clock,+        containers,+        aeson,+        containers,         ghc-prim,+        Hoed >= 0.5,+        libgraph >= 1.14,         extra,-        containers,+        deepseq,         directory,+        hashable,+        monoidal-containers,         template-haskell,         open-browser,+        text,         uniplate,+        unordered-containers,         js-jquery,-        ansi-wl-pprint+        prettyprinter,+        prettyprinter-compat-ansi-wl-pprint,+        vector      exposed-modules:         Debug-        Debug.Record+        Debug.Hoed+        Debug.DebugTrace+        Debug.Util+        Debug.Variables      other-modules:-        Debug.Variables         Paths_debug +executable debug-pp+  main-is: DebugPP.hs+  ghc-options:         -main-is DebugPP+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , directory+    , filepath+    , yaml+  default-language: Haskell2010+ test-suite debug-test     default-language: Haskell2010     type: exitcode-stdio-1.0     main-is: Main.hs     hs-source-dirs: test-+    other-modules:+        Variables+        Util+        Hoed     build-depends:         base == 4.*,+        directory,         extra,+        aeson,+        bytestring,+        containers,+        filepath,+        text,         debug

@@ -31,7 +31,7 @@         </td>     </tr>     <tr>-        <td rowspan="2" width="25%" style="padding-right:40px;">+        <td rowspan="3" width="25%" style="padding-right:40px;">             <h2>Functions</h1>             <select id="function-drop" style="width:100%;"><option>(All)</option></select><br/>             <input id="function-text" style="margin-top:5px;width:100%;" type="text" placeholder="Filter (using regex)" />@@ -47,11 +47,11 @@             <h2>Variables</h2>             <ul id="function-variables"></ul>         </td>+    </tr>+    <tr id="function-depends-section">         <td>-            <!--             <h2>Calls</h2>-            Call stack-            -->+            <ul id="function-depends"</ul>         </td>     </tr> </table>

@@ -38,18 +38,91 @@             source = source.substr(res[0].length);         }     }++    showCallStack(i);+     $("#function-variables").empty();     var variables = [];+    var seenDepends = false;+     for (var s in t)     {-        if (s == "") continue;-        variables.push(s + " = " + trace.variables[t[s]]);+        if (s == "" || s == "$parents" || s == "$depends") continue;+        else+            variables.push(s + " = " + trace.variables[t[s]]);     }     variables = variables.sort();     for (var i = 0; i < variables.length; i++)-        $("#function-variables").append($("<li>" + escapeHTML(variables[i]) + "</li>"));+        $("#function-variables").append($("<li><pre>" + escapeHTML(variables[i]) + "</pre></li>")); } +function showCallStack(me)+{+    var t = trace.calls[me];+    var d = t["$depends"];+    if(t["$parents"] == null && d == null)+        $("#function-depends-section").hide();+    else {+        var i;+        var par = me;+        var parents = [];+        var depends = [];+        var msg;+        var these;+        $("#function-depends").empty();+        // parents+        while(true){+            these = trace.calls[par]["$parents"];+            if(these == null || these.Length == 0) {+                break;+            }+            // assumes one parent only+            par = these[0];+            msg = renderCall(par);+            parents.unshift("<li><a href='javascript:showCall(" + par + ")'>" + escapeHTML(msg) + "</a></li>");++        }+        // depends+        for(i in d) {+            msg = renderCall(d[i]);+            depends.push("<li><a href='javascript:showCall(" + d[i] + ")'>" + escapeHTML(msg) + "</a></li>");+        }+        // assembling the call stack. There must be a better way...+        var callstack = $("#function-depends");+        var cursor = callstack;+        var temp;+        for(i in parents) {+            temp = $("<ul>");+            cursor.append($(parents[i]).append(temp));+            cursor = temp;+        }+        temp = $("<ul>");+        cursor = cursor.append($("<li>" + escapeHTML(renderCall(me)) + "</li>").append(temp));+        cursor = temp;+        for(i in depends)+            cursor.append($(depends[i]));+        $("#function-depends-section").show();+    }+ }+function renderCall(i)+{+     var t = trace.calls[i];+     var inf = trace.functions[t[""]];+     var words = [];+     words.push(inf.name);+     for (var j = 0; j < inf.arguments.length; j++)+        {+            var v = inf.arguments[j];+            if (v in t)+                words.push(trace.variables[t[v]]);+            else+                words.push("_");+        }+     words.push("=");+     words.push(trace.variables[t[inf.result]]);+     var msg = words.join(" ");+     return msg;+} function showCalls() {     var name = $("#function-drop").val();@@ -63,22 +136,8 @@     var ul = $("#function-list").empty();     for (var i = 0; i < trace.calls.length; i++)     {-        var t = trace.calls[i];-        var inf = trace.functions[t[""]];-        if (name != "(All)" && name != inf.name) continue;-        var words = [];-        words.push(inf.name);-        for (var j = 0; j < inf.arguments.length; j++)-        {-            var v = inf.arguments[j];-            if (v in t)-                words.push(trace.variables[t[v]]);-            else-                words.push("_");-        }-        words.push("=");-        words.push(trace.variables[t[inf.result]]);-        var msg = words.join(" ");+        var msg = renderCall(i);+        if (name != "(All)" && name != trace.functions[trace.calls[i][""]].name) continue;         if (!regex.test(msg)) continue;         ul.append($("<li><a href='javascript:showCall(" + i + ")'>" + escapeHTML(msg) + "</a></li>"));     }@@ -88,7 +147,8 @@ {     var funcNames = [];     for (var i = 0; i < trace.functions.length; i++)-        funcNames.push(trace.functions[i].name);+        if (funcNames.indexOf(trace.functions[i].name) === -1)+            funcNames.push(trace.functions[i].name);     funcNames = funcNames.sort();     var drop = $("#function-drop");     for (var i = 0; i < funcNames.length; i++)

@@ -1,110 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase #-}---- | Module for debugging Haskell programs. To use, take the functions that---   you are interested in debugging, e.g.:------ > module QuickSort(quicksort) where--- > import Data.List--- >--- > quicksort :: Ord a => [a] -> [a]--- > quicksort [] = []--- > quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt--- >     where (lt, gt) = partition (<= x) xs------   Turn on the @TemplateHaskell@ and @ViewPatterns@ extensions, import "Debug",---   indent your code and place it under a call to 'debug', e.g.:------ > {-# LANGUAGE TemplateHaskell, ViewPatterns #-}--- > module QuickSort(quicksort) where--- > import Data.List--- > import Debug--- >--- > debug [d|--- >    quicksort :: Ord a => [a] -> [a]--- >    quicksort [] = []--- >    quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt--- >        where (lt, gt) = partition (<= x) xs--- >    |]------   We can now run our debugger with:------ > $ ghci QuickSort.hs--- > GHCi, version 8.2.1: http://www.haskell.org/ghc/  :? for help--- > [1 of 1] Compiling QuickSort        ( QuickSort.hs, interpreted )--- > Ok, 1 module loaded.--- > *QuickSort> quicksort "haskell"--- > "aehklls"--- > *QuickSort> debugView------   The final call to 'debugView' starts a web browser to view the recorded information.---   Alternatively call 'debugSave' to write the web page to a known location.------   For more ways to view the result (e.g. producing JSON) or record traces (without using---   @TemplateHaskell@) see "Debug.Record".-module Debug(-    -- * Generate trace-    debug,-    -- * View a trace-    debugView, debugSave, debugPrint,-    -- * Clear a trace-    debugClear,-    ) where--import Debug.Record-import Data.List.Extra-import Data.Maybe-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Data.Generics.Uniplate.Data----- | A @TemplateHaskell@ wrapper to convert a normal function into a traced function.---   For an example see "Debug". Inserts 'funInfo' and 'var' calls.-debug :: Q [Dec] -> Q [Dec]-debug q = do-    decs <- q-    let askSig x = find (\case SigD y _ -> x == y; _ -> False) decs-    mapM (adjustDec askSig) decs----- | List all the type variables of kind * (or do the best you can)-kindStar :: Type -> Q [Name]--- in Q so we should be able to use 'reify' to do a better job-kindStar t = return $-    nubOrd [x | VarT x <- universe t] \\     -- find all variables-    nubOrd [x | AppT (VarT x) _ <- universe t] -- delete the "obvious" ones---adjustDec :: (Name -> Maybe Dec) -> Dec -> Q Dec--- try and shove in a "Show a =>" if we can-adjustDec askSig (SigD name (ForallT vars ctxt typ)) = do-    vs <- kindStar typ-    return $ SigD name $ ForallT vars (nubOrd $ map (AppT (ConT ''Show) . VarT) vs ++ ctxt) typ-adjustDec askSig (SigD name typ) = adjustDec askSig $ SigD name $ ForallT [] [] typ-adjustDec askSig o@(FunD name clauses@(Clause arity _ _:_)) = 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`-            toLit name `AppE`-            LitE (StringL $ prettyPrint $ maybeToList (askSig name) ++ [o]) `AppE`-            ListE (map (toLitPre "$") args) `AppE`-            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-    return $ FunD name [Clause (map VarP args) (NormalB body) [FunD inner clauses2]]-adjustDec askSig x = return x--prettyPrint = pprint . transformBi f-    where f (Name x _) = Name x NameS -- avoid nasty qualifications+module Debug(module Debug.Variables) where -adjustPat :: Name -> Pat -> Pat-adjustPat tag (VarP x) = ViewP (VarE 'var `AppE` VarE tag `AppE` toLit x) (VarP x)-adjustPat tag x = x+import Debug.Variables -toLit = toLitPre ""-toLitPre pre (Name (OccName x) _) = LitE $ StringL $ pre ++ x

@@ -0,0 +1,235 @@+{-# 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 qualified Language.Javascript.JQuery as JQuery+import Web.Browser+import Paths_debug+import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>), (<>))+++-- | 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"+    jquery <- TL.readFile =<< JQuery.file+    let trace = encodeToLazyText db+    let script a = "<script>\n" <> a <> "\n</script>"+    let f x | "trace.js" `TL.isInfixOf` x = script ("var trace =\n" <> trace <> ";")+            | "debug.js" `TL.isInfixOf` x = script debug+            | "code.jquery.com/jquery" `TL.isInfixOf` x = script jquery+            | 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

@@ -0,0 +1,419 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports    #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE ViewPatterns      #-}++-- | An alternative backend for lazy debugging with call stacks built on top of the "Hoed" package.+--+--   Instrumentation is done via a TH wrapper, which requires the following extensions:+--+--  - 'TemplateHaskell'+--  - 'PartialTypeSignatures'+--  - 'ViewPatterns'+--  - 'ExtendedDefaultRules'+--  - 'FlexibleContexts'+--+--   Moreover, 'Observable' instances are needed for value inspection. The 'debug'' template haskell wrapper can automatically insert these for 'Generic' types.+--+-- > {-# LANGUAGE TemplateHaskell, ViewPatterns, PartialTypeSignatures, ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -Wno-partial-type-signatures #-}+-- > module QuickSort(quicksort) where+-- > import Data.List+-- > import Debug.Hoed+-- >+-- > debug [d|+-- >    quicksort :: Ord a => [a] -> [a]+-- >    quicksort [] = []+-- >    quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+-- >        where (lt, gt) = partition (<= x) xs+-- >    |]+--+-- Now we can debug our expression under 'debugRun':+--+-- > $ ghci examples/QuickSortHoed.hs+-- > GHCi, version 8.2.1: http://www.haskell.org/ghc/  :? for help+-- > [1 of 1] Compiling QuickSortHoed    ( QuickSortHoed.hs, interpreted )+-- > Ok, 1 module loaded.+-- > *QuickSort> debugRun $ quicksort "haskell"+-- > "aehklls"+--+-- After our expression is evaluated a web browser is started displaying the recorded+-- information.+--+-- To debug an entire program, wrap the 'main' function below 'debugRun'.+module Debug.Hoed+  (+    debug+  , debug'+  , Config(..)+  , debugRun+    -- * Generate a trace+  , getDebugTrace+    -- * Reexported from Hoed+  , Observable(..)+  , observe+  , HoedOptions(..)+  , defaultHoedOptions+  ) where++import           Control.Monad+import           Data.Bifunctor+import           Data.Char+import           Data.Generics.Uniplate.Data+import           Data.Graph.Libgraph+import           Data.Hashable+import qualified Data.HashMap.Monoidal       as HM+import qualified Data.HashMap.Strict         as HMS+import qualified Data.Map.Strict             as Map+import qualified Data.HashSet                as Set+import           Data.List+import           Data.Maybe+import           Data.Monoid+import           Data.Text                   (Text, pack)+import qualified Data.Text                   as T+import "Hoed"    Debug.Hoed+import           Debug.Hoed.Render+import           Debug.Util+import           Debug.DebugTrace            as D (CallData (..),+                                                   DebugTrace (..),+                                                   Function (..),+                                                   debugViewTrace+                                                   )+import           GHC.Exts                    (IsList (..))+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import           System.Clock++{-# ANN module ("hlint: ignore Redundant bracket" :: String) #-}++-- | Runs the program collecting a debugging trace and then opens a web browser to inspect it.+--+--   @ main = debugRun $ do+--       ...+--   @+debugRun :: IO () -> IO ()+debugRun program = getDebugTrace defaultHoedOptions {prettyWidth = 160, verbose = Verbose} program >>= debugViewTrace++-- | Runs the program collecting a debugging trace+getDebugTrace :: HoedOptions -> IO () -> IO DebugTrace+getDebugTrace hoedOptions program = do+  hoedAnalysis <- runO' hoedOptions program+  putStrLn "Please wait while the debug trace is constructed..."+  let !compTree = hoedCompTree hoedAnalysis+  t <- getTime Monotonic+  let result = convert compTree+      !_     = length(variables result)+  t' <- getTime Monotonic+  let compTime :: Double = fromIntegral(toNanoSecs(diffTimeSpec t t')) * 1e-9+  putStrLn $ "=== Debug Trace (" ++ show compTime ++ " seconds) ==="+  return result++type a :-> b = HM.MonoidalHashMap a b++data HoedFunctionKey = HoedFunctionKey+  { label   :: !Text+  , arity   :: !Int+  , clauses :: ![Text]+  }+  deriving (Eq)++instance Hashable HoedFunctionKey where+  hashWithSalt s HoedFunctionKey{..} =+    s `hashWithSalt` label+      `hashWithSalt` arity+      `hashWithSalt` clauses++type HoedCallKey = Int++data HoedCallDetails = HoedCallDetails+  { argValues+  , clauseValues :: ![Hashed Text]+  , result :: !(Hashed Text)+  , depends, parents :: ![HoedCallKey]+  } deriving (Eq, Generic, Hashable)+++---------------------------------------------------------------------------+-- Cached pred and succ relationships++data AnnotatedCompTree = AnnotatedCompTree+  { compTree           :: CompTree+  , predsMap, succsMap:: HMS.HashMap Vertex [Vertex]+  }+getPreds :: AnnotatedCompTree -> Vertex -> [Vertex]+getPreds act v = fromMaybe [] $ HMS.lookup v (predsMap act)++getSuccs :: AnnotatedCompTree -> Vertex -> [Vertex]+getSuccs act v =  fromMaybe [] $ HMS.lookup v (succsMap act)++annotateCompTree :: CompTree -> AnnotatedCompTree+annotateCompTree compTree = AnnotatedCompTree{..}  where+  predsMap  = HMS.fromListWith (++) [ (t, [s]) | Arc s t _ <- arcs compTree]+  succsMap  = HMS.fromListWith (++) [ (s, [t]) | Arc s t _ <- arcs compTree]++---------------------------------------------------------------------------+hoedCallValues :: HoedCallDetails -> [Hashed Text]+hoedCallValues HoedCallDetails{..} = result : (argValues ++ clauseValues)++getRelatives :: (Vertex -> [Vertex]) -> Vertex -> [Int]+getRelatives rel v =+      [ stmtIdentifier+        | v'@Vertex {vertexStmt = CompStmt {stmtIdentifier, stmtDetails = StmtLam {}}} <- rel v+      ] +++      [ callKey+        | v'@Vertex {vertexStmt = CompStmt {stmtDetails = StmtCon {}}} <- rel v+        , callKey <- getRelatives rel v'+      ]++extractHoedCall :: AnnotatedCompTree -> Vertex -> Maybe (Hashed HoedFunctionKey, HoedCallKey, HoedCallDetails)+extractHoedCall hoedCompTree v@Vertex {vertexStmt = c@CompStmt {stmtDetails = StmtLam {..}, ..}} =+  Just+    ( hashed $ HoedFunctionKey (stmtLabel) (length stmtLamArgs) (map fst clauses)+    , stmtIdentifier+    , HoedCallDetails stmtLamArgs (map snd clauses) stmtLamRes depends parents)+  where+    clauses =+      [ (stmtLabel, stmtCon)+      | Vertex {vertexStmt = CompStmt {stmtLabel, stmtDetails = StmtCon {..}}} <-+          getSuccs hoedCompTree v+      ]+    depends = snub $ getRelatives (getSuccs hoedCompTree) v+    parents = snub $ getRelatives (getPreds hoedCompTree) v++extractHoedCall _ _ = Nothing++-- | Convert a 'Hoed' trace to a 'debug' trace+convert :: CompTree -> DebugTrace+convert hoedCompTree = DebugTrace {..}+  where+    hoedFunctionCalls :: Hashed HoedFunctionKey :-> [(HoedCallKey, HoedCallDetails)]+    hoedFunctionCalls =+      HM.fromList+        [ (fnKey, [(callKey, callDetails)])+        | Just (fnKey, callKey, callDetails) <-+            map (extractHoedCall (annotateCompTree hoedCompTree)) (vertices hoedCompTree)+        ]+    sortedFunctionCalls =+      sortOn (\(unhashed -> x, _) -> (label x, arity x)) $ toList hoedFunctionCalls++    variablesHashed :: [Hashed Text]+    variablesHashed =+      Set.toList $+      Set.fromList $+      foldMap (foldMap (hoedCallValues . snd)) hoedFunctionCalls++    variables = map unhashed variablesHashed++    lookupFunctionIndex =+      fromMaybe (error "bug in convert: lookupFunctionIndex") .+      (`HMS.lookup` HMS.fromList (zip (map fst sortedFunctionCalls) [0 ..]))++    lookupVariableIndex =+      fromMaybe (error "bug in convert: lookupVariableIndex") .+      (`HMS.lookup` HMS.fromList (zip variablesHashed [0 ..]))++    lookupCallIndex =+      fromMaybe (error "bug in convert: lookupCallIndex") .+      (`HMS.lookup` HMS.fromList (zip (map fst callsTable) [0 ..]))++    (functions, concat -> callsTable) =+      unzip+      [ (Function{..}+        ,[( callId, CallData {..})+         | (callId, HoedCallDetails {..}) <- toList calls+         , let callVals =+                 map (second lookupVariableIndex) $+                 ("$result", result) :+                 zipWith (\i v -> ("$arg" <> pack (show i), v)) [(1::Int) ..] argValues +++                 zip clauses clauseValues+         , let callDepends = map lookupCallIndex depends+         , let callParents = map lookupCallIndex parents+         ])+      | (k@(unhashed -> HoedFunctionKey {..}), calls) <- sortedFunctionCalls+      , let callFunctionId = lookupFunctionIndex k+      , let funResult = "$result"+      , let funArguments = map (\i -> "$arg" <> pack(show i)) [1 .. arity] ++ clauses+      -- HACK Expects a multiline label with the function name in the first line, and the code afterwards+      , let (funName,funSource) = T.break (=='\n') label+      ]++    calls = map snd callsTable++snub :: Ord a => [a] -> [a]+snub = map head . group . sort++----------------------------------------------------------------------------+-- Template Haskell++data Config = Config+  { generateGenericInstances      :: Bool      -- ^ Insert @deriving stock Generic@ on type declarations that don't already derive 'Generic'. Requires @DeriveGeneric@ and @DerivingStrategies@.+  , generateObservableInstances   :: Bool      -- ^ Insert @deriving anyclass Observable@ on type declarations that don't already derive 'Observable'. Requires @DeriveAnyClass@ and @DerivingStrategies@.+  , excludeFromInstanceGeneration :: [String]  -- ^ Exclude types from instance generation by name (unqualified).+  }++-- | A @TemplateHaskell@ wrapper to convert normal functions into traced functions.+debug :: Q [Dec] -> Q [Dec]+debug = debug' (Config False False [])++-- | A @TemplateHaskell@ wrapper to convert normal functions into traced functions+--   and optionally insert 'Observable' and 'Generic' instances.+debug' :: Config -> Q [Dec] -> Q [Dec]+debug' Config{..} q = do+  missing <-+    filterM+      (fmap not . isExtEnabled)+      ([ ViewPatterns+       , PartialTypeSignatures+       , ExtendedDefaultRules+       , FlexibleContexts+       ]+#if __GLASGOW_HASKELL__ >= 802+       +++       [DeriveAnyClass | generateObservableInstances] +++       [DerivingStrategies | generateObservableInstances] +++       [DeriveGeneric | generateGenericInstances]+#endif+      )+  when (missing /= []) $+    error $+    "\ndebug [d| ... |] requires additional extensions:\n" +++    "{-# LANGUAGE " ++ intercalate ", " (map show missing) ++ " #-}\n"+  decs <- q+  let askSig x =+        listToMaybe $+        mapMaybe+          (\case+             SigD y s+               | x == y -> Just s+             _ -> Nothing)+          decs+  let checkSig = maybe True (not . hasRankNTypes) . askSig+  let sourceNames =+        mapMaybe+          (\case+             FunD n _ -> Just n+             ValD (VarP n) _ _ -> Just n+             _ -> Nothing)+          decs+  names <-+    sequence [(n, ) <$> newName (mkDebugName (nameBase n)) | n <- sourceNames]+  let  -- HACK We embed the source code of the function in the label,+       --      which is then unpacked by 'convert'+      createLabel n dec = nameBase n ++ "\n" ++ prettyPrint dec++#if __GLASGOW_HASKELL__ >= 802+      excludedSet = Set.fromList excludeFromInstanceGeneration+      updateDerivs derivs+        | hasGenericInstance <- not $ null $ filterDerivingClausesByName ''Generic derivs+        = [ DerivClause (Just StockStrategy)    [ConT ''Generic]+          | not hasGenericInstance+          , generateGenericInstances+          ] +++          [ DerivClause (Just AnyclassStrategy) [ConT ''Observable]+          | [] == filterDerivingClausesByName ''Observable derivs+          , hasGenericInstance || generateGenericInstances+          ] +++          derivs+      filterDerivingClausesByName n' derivs =+        [ it | it@(DerivClause _ preds) <- derivs , ConT n <- preds , n == n']+#endif+  fmap concat $+    forM decs $ \dec ->+      case dec of+        ValD (VarP n) b clauses+          | checkSig n -> do+            let Just n' = lookup n names+                label = createLabel n dec+            newDecl <-+              funD n [clause [] (normalB [|observe (pack label) $(varE n')|]) []]+            let clauses' = transformBi adjustValD clauses+            return [newDecl, ValD (VarP n') b clauses']+        FunD n clauses+          | checkSig n -> do+            let Just n' = lookup n names+                label = createLabel n dec+            newDecl <-+              funD n [clause [] (normalB [|observe (pack label) $(varE n')|]) []]+            let clauses' = transformBi (adjustInnerSigD . adjustValD) clauses+            return [newDecl, FunD n' clauses']+        SigD n ty+          | Just n' <- lookup n names+          , not (hasRankNTypes ty) -> do+            let ty' = adjustTy ty+            ty'' <- renameForallTyVars ty'+            return [SigD n ty', SigD n' ty'']+#if __GLASGOW_HASKELL__ >= 802+        DataD cxt1 name tt k cons derivs+          | not $ Set.member (prettyPrint name) excludedSet+          -> return [DataD cxt1 name tt k cons $ updateDerivs derivs]+        NewtypeD cxt1 name tt k cons derivs+          | not $ Set.member (prettyPrint name) excludedSet+          -> return [NewtypeD cxt1 name tt k cons $ updateDerivs derivs]+#endif+        _ -> return [dec]+++mkDebugName :: String -> String+mkDebugName n@(c:_)+  | isAlpha c || c == '_' = n ++ "_debug"+  | otherwise = n ++ "??"+mkDebugName [] = error "unreachable: impossible"++adjustInnerSigD :: Dec -> Dec+adjustInnerSigD (SigD n ty) = SigD n (adjustTy ty)+adjustInnerSigD other       = other++-- Add a wildcard for Observable a+adjustTy :: Type -> Type+adjustTy (ForallT vars ctxt typ) =+    ForallT vars (delete WildCardT ctxt ++ [WildCardT]) typ+adjustTy other = adjustTy $ ForallT [] [] other++-- Tyvar renaming is a work around for http://ghc.haskell.org/trac/ghc/ticket/14643+renameForallTyVars :: Type -> Q Type+renameForallTyVars (ForallT vars ctxt typ) = do+  let allVarNames = case vars of+                      []-> snub $ universeBi ctxt ++ universeBi typ+                      _  -> map getVarNameFromTyBndr vars+  vv <- Map.fromList <$> mapM (\v -> (v,) <$> newName (pprint v)) allVarNames+  let Just renamedCtxt = transformBiM (applyRenaming vv) ctxt+      Just renamedTyp  = transformBiM (applyRenaming vv) typ+      Just renamedVars = mapM (applyRenamingToTyBndr vv) vars+  return $+    ForallT renamedVars renamedCtxt renamedTyp++renameForallTyVars other = return other++applyRenaming :: Map.Map Name Name -> Type -> Maybe Type+applyRenaming nn (VarT n) = VarT <$> Map.lookup n nn+applyRenaming _ other     = return other++getVarNameFromTyBndr :: TyVarBndr -> Name+getVarNameFromTyBndr (PlainTV n)    = n+getVarNameFromTyBndr (KindedTV n _) = n++applyRenamingToTyBndr :: Map.Map Name Name -> TyVarBndr -> Maybe TyVarBndr+applyRenamingToTyBndr vv (PlainTV n)    = PlainTV <$> Map.lookup n vv+applyRenamingToTyBndr vv (KindedTV n k) = (`KindedTV` k) <$> Map.lookup n vv++adjustValD :: Dec -> Dec+adjustValD decl@ValD{} = transformBi adjustPat decl+adjustValD other       = other++adjustPat :: Pat -> Pat+adjustPat (VarP x) = ViewP (VarE 'observe `AppE` (VarE 'pack `AppE` toLit x)) (VarP x)+adjustPat x        = x++toLit :: Name -> Exp+toLit (Name (OccName x) _) = LitE $ StringL x

@@ -1,208 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -- 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.Record(-    -- * Recording-    Function(..),-    Call,-    funInfo, fun, var,-    -- * Viewing-    debugClear,-    debugPrint, debugJSON,-    debugView, debugSave-    ) where--import Debug.Variables-import Control.Exception-import Control.Monad-import Data.IORef-import Data.List.Extra-import Data.Maybe-import Data.Tuple.Extra-import System.IO-import System.Directory-import System.IO.Unsafe-import Text.Show.Functions() -- Make sure the Show for functions instance exists-import qualified Data.Map as Map-import qualified Language.Javascript.JQuery as JQuery-import Web.Browser-import Paths_debug-import Text.PrettyPrint.ANSI.Leijen as PP----- | Metadata about a function, used to drive the HTML view.-data Function = Function-    {funName :: String -- ^ Function name-    ,funSource :: String -- ^ Function source, using @\n@ to break lines-    ,funArguments :: [String] -- ^ Variables for the arguments to the function-    ,funResult :: String -- ^ Variable for the result of the function-    }-    deriving (Eq,Ord,Show)---- | A single function call, used to attach additional information-data Call = Call Function (IORef [(String, Var)])--{-# NOINLINE refVariables #-}-refVariables :: IORef Variables-refVariables = unsafePerformIO $ newIORef newVariables--{-# NOINLINE refCalls #-}-refCalls :: IORef [Call]-refCalls = unsafePerformIO $ newIORef []---- | Clear all debug information. Useful when working in @ghci@ to reset---   any previous debugging work and reduce the amount of output.-debugClear :: IO ()-debugClear = do-    writeIORef refVariables newVariables-    writeIORef refCalls []---- | Print information about the observed function calls to 'stdout',---   in a human-readable format.-debugPrint :: IO ()-debugPrint = do-    calls <- readIORef refCalls-    concs <- mapM getCall calls-    let docs = map call $ nubOrd $ reverse concs-    putDoc (vcat docs <> hardline)-    where-          -- "realise" the call (needed to nub them)-          getCall :: Call -> IO (Function, [(String, Var)])-          getCall (Call f is) = do sv <- readIORef is-                                   return (f, sv)--          call :: (Function, [(String, Var)]) -> Doc-          call (f, vs) =-                   let ass = creaAssoc . reverse $ vs-                       hdr = bold $ header ass f-                   in hang 5 $ hdr <$$> body ass--          -- stripping the index-          creaAssoc :: [(String, Var)] -> [(String, String)]-          creaAssoc svs = map (second varShow) svs--          header :: [(String, String)] -> Function -> Doc-          header ass f = text "\n*"       <+>-                         text (funName f) <+>-                         arguments ass    <+>-                         text "="         <+>-                         result ass--          arguments :: [(String, String)] -> Doc-          arguments ass =-                let fass = filter (\(t, _) -> take 4 t == "$arg") ass-                    args = map snd fass-                in hsep (map text args)--          result :: [(String, String)] -> Doc-          result = text . fromMaybe "no result!" . lookup "$result"--          body :: [(String, String)] -> Doc-          body svs = vsep $ map bodyLine svs--          bodyLine :: (String, String) -> Doc-          bodyLine (t, v) = text t <+> text "=" <+> text v---- | 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.-debugJSON :: IO String-debugJSON = do-    vars <- readIORef refVariables-    vars <- return $ map (jsonString . varShow) $ listVariables vars-    calls <- readIORef refCalls-    let infos = nubOrd [x | Call x _ <- calls]-    let infoId = Map.fromList $ zip infos [0::Int ..]-    let funs = [jsonMap-            [("name",show funName)-            ,("source",show funSource)-            ,("arguments",show funArguments)-            ,("result",show funResult)-            ]-            | Function{..} <- infos]-    calls <- forM (reverse calls) $ \(Call info vars) -> do-        vars <- readIORef vars-        return $ jsonMap $ ("", show $ infoId Map.! info) : [(k, show $ varId v) | (k, v) <- reverse vars]-    return $-        "{\"functions\":\n" ++ jsonList funs ++-        ",\"variables\":\n" ++ jsonList vars ++-        ",\"calls\":\n" ++ jsonList (nubOrd calls) ++-        "}"-    where-        jsonList [] = "  []"-        jsonList (x:xs) = unlines $ ("  [" ++ x) : map ("  ," ++) xs ++ ["  ]"]-        jsonMap xs = "{" ++ intercalate "," [jsonString k ++ ":" ++ v | (k,v) <- xs] ++ "}"-        jsonString = show---- | Save information about observed functions to the specified file, in HTML format.-debugSave :: FilePath -> IO ()-debugSave file = do-    html <- readFile =<< getDataFileName "html/debug.html"-    debug <- readFile =<< getDataFileName "html/debug.js"-    jquery <- readFile =<< JQuery.file-    trace <- debugJSON-    let script a = "<script>\n" ++ a ++ "\n</script>"-    let f x | "trace.js" `isInfixOf` x = script ("var trace =\n" ++ trace ++ ";")-            | "debug.js" `isInfixOf` x = script debug-            | "code.jquery.com/jquery" `isInfixOf` x = script jquery-            | otherwise = x-    writeFile file $ unlines $ map f $ lines html---- | Open a web browser showing information about observed functions.-debugView :: IO ()-debugView = do-    tdir <- getTemporaryDirectory-    file <- bracket-        (openTempFile tdir "debug.html")-        (hClose . snd)-        (return . fst)-    debugSave file-    b <- openBrowser file-    unless b $-        putStrLn $-            "Failed to start a web browser, open: " ++ file ++ "\n" ++-            "In future you may wish to use 'debugSave'."---#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--{-# NOINLINE fun #-}--- | Called under a lambda with a function name to provide a unique context for---   a particular call, e.g.:------ > tracedAdd x y = fun "add" $ \t -> var t "x" x + var t "y" y------   This function involves giving identity to function calls, so is unsafe,---   and will only work under a lambda.-fun :: Show a => String -> (Call -> a) -> a-fun name = funInfo $ Function name [] [] []---- | A version of 'fun' allowing you to pass further information about the---   'Function' which is used when showing debug views.-funInfo :: Show a => Function -> (Call -> a) -> a-{-# NOINLINE funInfo #-}-funInfo info f = unsafePerformIO $ do-    ref <- newIORef []-    let x = Call info ref-    atomicModifyIORef refCalls $ \v -> (x:v, ())-    return $ f x--{-# NOINLINE var #-}--- | Used in conjunction with 'fun' to annotate variables. See 'fun' for an example.-var :: Show a => Call -> String -> a -> a-var (Call _ ref) name val = unsafePerformIO $ do-    var <- atomicModifyIORef refVariables $ addVariable val-    atomicModifyIORef ref $ \v -> ((name, var):v, ())-    return val

@@ -0,0 +1,64 @@+-- | Module containing functions required by test code. Not part of the public interface.+module Debug.Util(+    hasRankNTypes,+    prettyPrint,+    -- * Exported for tests only+    mkLegalInfixVar,+    removeLet,+    removeExtraDigits+    ) where++import           Data.Data+import           Data.Generics.Uniplate.Data+import           Data.List.Extra+import qualified Data.Map.Strict             as M+import           Data.Maybe+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++-- | Discover the function name inside (possibly nested) let expressions+--   Transform strings of the form "let (var tag "f" -> f) = f x in f_1" into "f"+removeLet :: String -> String+removeLet s =+    if "let" `isInfixOf` fst (word1 s)+        then case stripInfix " = " s of+            Just pair -> removeLet (snd pair)+            Nothing   -> s    -- this shouldn't happen...+        else fst $ word1 s++-- | Remove possible _n suffix from discovered function names+removeExtraDigits :: String -> String+removeExtraDigits str = case stripInfixEnd "_" str of+    Just s  -> fst s+    Nothing -> str++-- | Trsansform infix operator into a valid variable name+-- | For example "++"" ---> "plus_plus"+-- | This transformed variable is not visible in the UI+mkLegalInfixVar :: String -> String+mkLegalInfixVar s =+    let f c acc = case M.lookup c opNames of+            Just "" -> acc -- no adl underscores when removing backtics+            Just s  -> s ++ "_" ++ acc+            Nothing -> c : acc+        removeTrailing_ x = fromMaybe x $ stripSuffix "_" x+    in removeTrailing_ $ foldr f "" s++-- | Legal variable names for each operator character+opNames :: M.Map Char String+opNames = M.fromList opList where+    opList = [ ('+', "plus"), ('-', "minus"), ('*', "star"), ('/', "div")+             , ('^', "caret"), ('~', "tilde"), ('%', "percent"), ('&', "amp")+             , ('=', "equals"), ('<', "lt"), ('>', "gt"), ('?', "quest"), (':', "cons")+             , ('.', "dot"), ('@', "at"), ('#', "hash"), ('!', "bang"), ('|', "bar")+             , ('`', "") -- remove backtics to form variable name+             ]++hasRankNTypes, hasRankNTypes' :: Type -> Bool+hasRankNTypes (ForallT _vars _ctxt typ) = hasRankNTypes' typ+hasRankNTypes typ                       = hasRankNTypes' typ+hasRankNTypes' typ = not $ null [ () | ForallT{} <- universe typ]++prettyPrint :: (Data a, Ppr a) => a -> String+prettyPrint = pprint . transformBi f+    where f (Name x _) = Name x NameS -- avoid nasty qualifications

@@ -1,21 +1,362 @@-{-# LANGUAGE MagicHash #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-unused-matches #-}+{-# OPTIONS -fno-warn-unused-imports #-}     -- Any moved from GHC.Prim to GHC.Types     -- so import both and use unused imports to get compatibility +-- | Module for debugging Haskell programs. To use, take the functions that+--   you are interested in debugging, e.g.:+--+-- > module QuickSort(quicksort) where+-- > import Data.List+-- >+-- > quicksort :: Ord a => [a] -> [a]+-- > quicksort [] = []+-- > quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+-- >     where (lt, gt) = partition (<= x) xs+--+--   Turn on the @TemplateHaskell@ and @ViewPatterns@ extensions, import "Debug",+--   indent your code and place it under a call to 'debug', e.g.:+--+-- > {-# LANGUAGE TemplateHaskell, ViewPatterns, PartialTypeSignatures #-}+-- > {-# OPTIONS_GHC -Wno-partial-type-signatures #-}+-- > module QuickSort(quicksort) where+-- > import Data.List+-- > import Debug+-- >+-- > debug [d|+-- >    quicksort :: Ord a => [a] -> [a]+-- >    quicksort [] = []+-- >    quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+-- >        where (lt, gt) = partition (<= x) xs+-- >    |]+--+--   We can now run our debugger with:+--+-- > $ ghci QuickSort.hs+-- > GHCi, version 8.2.1: http://www.haskell.org/ghc/  :? for help+-- > [1 of 1] Compiling QuickSort        ( QuickSort.hs, interpreted )+-- > Ok, 1 module loaded.+-- > *QuickSort> quicksort "haskell"+-- > "aehklls"+-- > *QuickSort> debugView+--+--   The final call to 'debugView' starts a web browser to view the recorded information.+--   Alternatively call 'debugSave' to write the web page to a known location.+--+--   For more ways to view the result (e.g. producing JSON) or record traces (without using+--   @TemplateHaskell@) see "Debug.DebugTrace". module Debug.Variables(-    Var, varId, varShow,-    Variables, listVariables, newVariables, addVariable+    debug,+    debugClear,+    debugRun,+    debugPrint,+    debugJSON,+    debugView,+    debugSave,+    DebugTrace(..),+    getDebugTrace,+    -- * Recording+    funInfo, fun, var,     ) where -import GHC.Types-import GHC.Prim-import Data.List.Extra-import Control.Exception-import System.IO.Unsafe-import Unsafe.Coerce+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 +-- | Run a computation and open a browser window showing observed function calls.+--+--   @ main = debugRun $ do+--       ...+--   @+debugRun :: IO a -> IO a+debugRun = bracket_ debugClear debugView +-- | Print information about the observed function calls to 'stdout',+--   in a human-readable format.+debugPrint :: IO ()+debugPrint = getDebugTrace >>= debugPrintTrace++-- | Save information about observed functions to the specified file, in HTML format.+debugSave :: FilePath -> IO ()+debugSave fp = debugSaveTrace fp =<< getDebugTrace++-- | Open a web browser showing information about observed functions.+debugView :: IO ()+debugView = getDebugTrace >>= debugViewTrace++-- | 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.+debugJSON :: IO String+debugJSON = B.unpack . debugJSONTrace <$> getDebugTrace++------------------------------------------------------------------+-- DebugTrace Backend++-- | A single function call, used to attach additional information+data Call = Call Function (IORef [(Text, Var)])++{-# NOINLINE refVariables #-}+refVariables :: IORef Variables+refVariables = unsafePerformIO $ newIORef newVariables++{-# NOINLINE refCalls #-}+refCalls :: IORef [Call]+refCalls = unsafePerformIO $ newIORef []++-- | Clear all debug information. Useful when working in @ghci@ to reset+--   any previous debugging work and reduce the amount of output.+debugClear :: IO ()+debugClear = do+    writeIORef refVariables newVariables+    writeIORef refCalls []++-- | Returns all the information about the observed function accumulated so far+--   in the variables.+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 = [] -- available in the Hoed backend but not in this one+          callParents = [] -- available in the Hoed backend but not in this one+      return CallData{..}+  return $ DebugTrace infos (map T.pack vars) callEntries++------------------------------------------------------------------+-- Instrumentation++{-# NOINLINE fun #-}+-- | Called under a lambda with a function name to provide a unique context for+--   a particular call, e.g.:+--+-- > tracedAdd x y = fun "add" $ \t -> var t "x" x + var t "y" y+--+--   This function involves giving identity to function calls, so is unsafe,+--   and will only work under a lambda.+fun :: Show a => String -> (Call -> a) -> a+fun name = funInfo $ Function (T.pack name) "" [] ""++-- | A version of 'fun' allowing you to pass further information about the+--   'Function' which is used when showing debug views.+funInfo :: Show a => Function -> (Call -> a) -> a+{-# NOINLINE funInfo #-}+funInfo info f = unsafePerformIO $ do+    ref <- newIORef []+    let x = Call info ref+    atomicModifyIORef refCalls $ \v -> (x:v, ())+    return $ f x++{-# NOINLINE var #-}+-- | Used in conjunction with 'fun' to annotate variables. See 'fun' for an example.+var :: Show a => Call -> String -> a -> a+var (Call _ ref) name val = unsafePerformIO $ do+    when (show val /= "<function>") $ do -- these make the variable list long without providing useful info+        var <- atomicModifyIORef refVariables $ addVariable val+        name' <- unShadowName ref $ pack name+        atomicModifyIORef ref $ \v -> ((name', var) :v, ())+    return val++-- | If a name is already being used, find the next available name by adding ' (prime) chars until+--   the resulting name is unique+unShadowName :: IORef [(Text, Var)] -> Text -> IO Text+unShadowName ioRef t = do+    pairs <- readIORef ioRef+    let matches = filter (isPrefixPrime t) $ map fst pairs+    if not (null matches)+        then do+            let lengths = map T.length matches+            let zipped = zip matches lengths+            let maxName = fst $ fromJust $ find (\p -> snd p == maximum lengths) zipped+            return $ maxName `T.append` "'"+        else return t++-- | Is the second string equal to the first plus some number of ' (prime) characters?+-- | e.g. x `isPrefixPrime` x' == true, x isPrefixPrime x'' == True, but x isPrefixPrime xs == False+isPrefixPrime :: Text -> Text -> Bool+isPrefixPrime s t = s == T.dropWhileEnd (== '\'') t++-- | A @TemplateHaskell@ wrapper to convert a normal function into a traced function.+--   For an example see "Debug". Inserts 'funInfo' and 'var' calls.+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+-- try and shove in a "_ =>" if we can, to capture necessary Show instances+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+    return $ Clause pats newBody decs++appsFromBody :: Name -> Body -> Q Body+appsFromBody _ b@(GuardedB _) = return b -- TODO: implement guards+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) = return d+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 -- infix symbol, e.g "++"+    if displayName == "$" --don't record $ as a function application+        then return e+        else do+            let legalInfixVar = mkLegalInfixVar displayName -- infix name as valid variable, e.g. "plus_plus"+            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   --TODO: These might need to be processed+adjustApp _ e = return e++-- Find the (unqualified) function name to use as the UI display name+expDisplayName :: Exp -> String+expDisplayName e =+    let name = removeLet $ (show . ppr) e+    in removeExtraDigits (takeWhileEnd (/= '.') ((head . words) name))++-- Same as expDisplayName but for infix functions+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 structures+ data Variables = Variables     Int -- Number in the array     [(Any, String)] -- Entries, (key a, show a), indexed from [n..0]@@ -42,7 +383,7 @@ 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 (n-i-1) $ snd $ xs !! i)+        Just i  -> (vs, Var (n-i-1) $ snd $ xs !! i)     where         keyA = unsafeCoerce a         showA = show a@@ -51,4 +392,4 @@ ptrEqual a b = unsafePerformIO $ do     a <- evaluate a     b <- evaluate b-    return (tagToEnum# (reallyUnsafePtrEquality# a b) :: Bool)+    return $ isTrue# (reallyUnsafePtrEquality# a b)

@@ -0,0 +1,271 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns    #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures  #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- GHC 8.0 doesn't know about COMPLETE pragmas++module DebugPP(main) where++import           Control.Monad+import           Data.Aeson.Types+import           Data.Char+import           Data.List+import           Data.Maybe+import           Data.Yaml.Config+import           GHC.Generics+import           System.Directory+import           System.Environment+import           System.Exit+import           System.FilePath+import           System.IO+import           Text.Printf++usage :: String -> String+usage progName = unlines [+  "Usage: ",+  progName ++ " [FILENAME] [SOURCE] [DEST]",+  "  Instrument Haskell module for debugging from SOURCE (derived from FILENAME) and write",+  "  standard Haskell to DEST.",+  "  If no FILENAME, use SOURCE as the original name.",+  "  If no DEST or if DEST is `-', write to standard output.",+  "  If no SOURCE or if SOURCE is `-', read standard input.",+  progName ++ " --defaults",+  "  Dump a well documented set of default config values to standard output."+  ]++data Config = Config_+  { _excluded                            :: Maybe [String]+  , _instrumentMain                      :: Maybe Bool+  , _useHoedBackend                      :: Maybe Bool+  , _disablePartialTypeSignatureWarnings :: Maybe Bool+  , _enableExtendedDefaultingRules       :: Maybe Bool+  , _generateObservableInstances         :: Maybe Bool+  , _generateGenericInstances            :: Maybe Bool+  , _excludedFromInstanceGeneration      :: Maybe [String]+  , _verbose                             :: Maybe Bool+  } deriving (Generic, Show)++configJsonOptions :: Options+configJsonOptions = defaultOptions{fieldLabelModifier = tail}++instance FromJSON Config where parseJSON = genericParseJSON configJsonOptions+instance ToJSON Config where toJSON = genericToJSON configJsonOptions++{-# COMPLETE Config #-}+pattern Config { excluded+               , instrumentMain+               , useHoedBackend+               , disablePartialTypeSignatureWarnings+               , enableExtendedDefaultingRules+               , generateGenericInstances+               , generateObservableInstances+               , excludedFromInstanceGeneration+               , verbose+               } <-+  Config_+  { _excluded = (fromMaybe [] -> excluded)+  , _instrumentMain = (fromMaybe True -> instrumentMain)+  , _useHoedBackend = (fromMaybe False -> useHoedBackend)+  , _disablePartialTypeSignatureWarnings = (fromMaybe True -> disablePartialTypeSignatureWarnings)+  , _enableExtendedDefaultingRules = (fromMaybe True -> enableExtendedDefaultingRules)+  , _generateObservableInstances = (fromMaybe True -> generateObservableInstances)+  , _generateGenericInstances = (fromMaybe False -> generateGenericInstances)+  , _excludedFromInstanceGeneration = (fromMaybe [] -> excludedFromInstanceGeneration)+  , _verbose = (fromMaybe False -> verbose)+  }+  where Config a b c d e f g h i = Config_ (Just a) (Just b) (Just c) (Just d) (Just e) (Just f) (Just g) (Just h) (Just i)++defaultConfig :: Config+defaultConfig = Config_ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++readConfig :: IO Config+readConfig = do+  cwd <- getCurrentDirectory+  home <- getHomeDirectory+  system <- getXdgDirectory XdgConfig "debug-pp"+  from <- filterM doesFileExist $+        [d </> ".debug-pp.yaml" | d <- reverse (ancestors cwd)] +++        [ system </> "config.yaml"+        , home </> ".debug-pp.yaml"]+  case from of+    [] -> return defaultConfig+    _  -> loadYamlSettings from [] ignoreEnv+  where+    ancestors = map joinPath . tail . inits . splitPath++defConfig :: String+defConfig = unlines+  ["# debug-pp configuration file"+  ,"# ==========================="+  ,""+  ,"# List of Haskell module names to exclude from instrumentation"+  ,"excluded: []"+  , ""+  , "# If true, use the Hoed backend for trace generation."+  , "useHoedBackend: false"+  , ""+  , "# If true then insert a call to debugRun in the main function."+  , "instrumentMain: true"+  , ""+  , "# When the Hoed backend is used, instruct the debug TH wrapper to insert Observable instances for types that derive Generic."+  , "generateObservableInstances: true"+  , ""+  , "# When the Hoed backend is used, instruct the debug TH wrapper to insert Generic instances for types that don't derive Generic."+  , "generateGenericInstances: false"+  , ""+  , "# If the hoed backend is used, insert the ExtendedDefaultRules pragma."+  , "enableExtendedDefaultingRules: true"+  , ""+  , ""+  , "# List of types excluded from instance generation"+  , "excludedFromInstanceGeneration: []"+  , ""+  , "# If true, print a line for every instrumented module."+  , "verbose: false"+  , ""+  ]++main :: IO ()+main = do+  args <- getArgs+  progName <- getProgName+  (orig, inp, out) <- case args of+    ["--defaults"] -> do+      putStrLn defConfig+      exitSuccess+    ["--help"] -> do+      putStrLn $ usage progName+      exitSuccess+    []     -> return ("input",Nothing,Nothing)+    [i]    -> return (i, Just i, Nothing)+    [i,o]  -> return (i, Just i, Just o)+    [orig,i,o] -> return (orig, Just i, Just o)+    _ -> do+      putStrLn $ usage progName+      error "Unrecognized set of command line arguments"+  hIn  <- maybe (return stdin)  (`openFile` ReadMode) inp+  hOut <- maybe (return stdout) (`openFile` WriteMode) out+  contents <- hGetContents hIn+  config@Config{..} <- readConfig+  hPutStr hOut $ instrument config contents+  unless (hOut == stdout) $ hClose hOut+  when verbose $+    putStrLn $ "[debug-pp] Instrumented " ++ orig++instrument :: Config -> String -> String+instrument Config {..} contents+  | name `elem` excluded = contents+  | otherwise = unlines [top', modules', body'']+  where+    (top, name, modules, body) = parseModule contents+    debugModule = "Debug" ++ if useHoedBackend then ".Hoed" else ""+    modules' = unlines $ modules +++      ["import qualified " ++ debugModule ++ " as Debug"] +++      ["import qualified GHC.Generics" | generateGenericInstances]+    top' =+      unlines $+      [ "{-# LANGUAGE TemplateHaskell #-}"+      , "{-# LANGUAGE PartialTypeSignatures #-}"+      , "{-# LANGUAGE ViewPatterns #-}"+      , "{-# LANGUAGE FlexibleContexts #-}"+      ] +++      [ "{-# OPTIONS -Wno-partial-type-signatures #-}"+      | disablePartialTypeSignatureWarnings+      ] +++      ["{-# LANGUAGE ExtendedDefaultRules #-}" | useHoedBackend && enableExtendedDefaultingRules] +++      ["{-# LANGUAGE DeriveAnyClass #-}"       | useHoedBackend && (generateObservableInstances || generateGenericInstances)] +++      ["{-# LANGUAGE DerivingStrategies #-}"   | useHoedBackend && (generateObservableInstances || generateGenericInstances)] +++      ["{-# LANGUAGE DeriveGeneric #-}"        | useHoedBackend && generateGenericInstances] +++      top+    body' =+      map+        (if instrumentMain+           then instrumentMainFunction+           else id)+        body+    debugWrapper+      | useHoedBackend && (generateGenericInstances || generateObservableInstances) =+        printf+          "Debug.debug' Debug.Config{Debug.generateGenericInstances=%s,Debug.generateObservableInstances=%s, Debug.excludeFromInstanceGeneration=%s}"+          (show generateGenericInstances)+          (show generateObservableInstances)+          (show excludedFromInstanceGeneration)+      | otherwise =+        "Debug.debug"+    body'' = unlines $ (debugWrapper ++ " [d|") : map indent (body' ++ ["  |]"])++instrumentMainFunction :: String -> String+instrumentMainFunction l+  | ('m':'a':'i':'n':rest) <- l+  , ('=':rest') <- dropWhile isSpace rest+  , not ("debugRun" `isPrefixOf` rest') = "main = Debug.debugRun $ " ++ rest'+  | otherwise = l++parseModule :: String -> ([String], String, [String], [String])+parseModule contents = (map fst top, name, modules, body)+  where+    contents' = annotateBlockComments (lines contents)+    moduleLine =+      findIndex (\(l,insideComment) -> not insideComment && isModuleLine l) contents'+    firstImportLine =+      findIndex (\(l, insideComment) -> not insideComment && isImportLine l) contents'+    lastPragmaLine =+      case takeWhile (\(_,(l, insideComment)) -> not insideComment && isPragmaLine l) (zip [(0::Int)..] contents') of+        [] -> Nothing+        xx -> Just $ fst $ last xx+    (top, rest)+      | Just l <- firstImportLine = splitAt (l-1) contents'+      | Just m <- moduleLine      = splitAt (m+1) contents'+      | Just p <- lastPragmaLine  = splitAt (p+1) contents'+      | otherwise = ([], contents')+    (reverse -> body0, reverse -> modules0) =+      break (\(l,insideComment) -> not insideComment && isImportLine l) (reverse rest)+    name+      | Just l <- moduleLine+      = takeWhile (\x -> not (isSpace x || x == '(')) $ drop 7 (fst $ contents' !! l)+      | otherwise+      = "Main"+    body = map fst $ dropWhile snd body0+    modules = map fst modules0 ++ map fst (takeWhile snd body0)++isModuleLine :: String -> Bool+isModuleLine l = "module " `isPrefixOf` l && all (\c -> isAlpha c || c `elem` " ().") l+isImportLine :: String -> Bool+isImportLine = ("import " `isPrefixOf`)+isPragmaLine :: String -> Bool+isPragmaLine = ("{-#" `isPrefixOf`)++indent :: String -> String+indent it@('#':_) = it+indent other      = "  " ++ other++-- Annotate every line with True if its inside the span of a block comment.+-- @+--   {- LANGUAGE foo -}     -- False+--   This is not inside {-  -- False+--   but this is -}         -- True+annotateBlockComments :: [String] -> [(String, Bool)]+annotateBlockComments = annotateBlockComments' False+annotateBlockComments' :: Bool -> [String] -> [(String, Bool)]+annotateBlockComments' _ [] = []+annotateBlockComments' False (l:rest) = (l,False) : annotateBlockComments' (startsBlockComment l) rest+annotateBlockComments' True  (l:rest) = (l,True) : annotateBlockComments' (not $ endsBlockComment l) rest++startsBlockComment :: String -> Bool+startsBlockComment line+    | Just l' <- dropUntilIncluding "{-" line = not $ endsBlockComment l'+    | otherwise = False++endsBlockComment :: String -> Bool+endsBlockComment line+    | Just l' <- dropUntilIncluding "-}" line = not $ startsBlockComment l'+    | otherwise = False++dropUntilIncluding :: Eq a => [a] -> [a] -> Maybe [a]+dropUntilIncluding needle haystack+  | [] <- haystack = Nothing+  | Just x <- stripPrefix needle haystack = Just x+  | x:rest <- haystack = (x:) <$> dropUntilIncluding needle rest

@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE ExtendedDefaultRules, FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+-- {-# OPTIONS_GHC -dth-dec-file #-} -- turn on to debug TH+module Hoed(main) where++import Control.Exception.Extra+import Debug.Hoed+import Debug.DebugTrace+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Lazy as B+import Util++#if __GLASGOW_HASKELL__ >= 802+debug [d|+    quicksort :: (a -> a -> Bool) -> [a] -> [a]+    quicksort op [] = []+    quicksort op (x:xs) = quicksort op lt ++ [x] ++ quicksort op gt+        where (lt, gt) = partition (op x) xs++    partition               :: (a -> Bool) -> [a] -> ([a],[a])+    {-# INLINE partition #-}+    partition p = foldr (select p) ([],[])++    select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+    select p x ~(ts,fs) | p x       = (x:ts,fs)+                        | otherwise = (ts, x:fs)+  |]+#endif++debug [d|+    foo :: m a -> m a+    foo = id++    listcomp, listmap :: Num a => a -> a+    listcomp y = sum [x*2 | x <- [1..y]]+    listmap y = sum $ map (\x -> 1+x*2) [1..y]+  |]++main :: IO ()+main = do+    trace <- getDebugTrace defaultHoedOptions $ do+#if __GLASGOW_HASKELL__ >= 802+      print (quicksort (<) "haskell")+#endif+      print (listmap (3::Int))+      print (listcomp (3::Int))+    -- see https://github.com/feuerbach/ansi-terminal/issues/47 as this test fails on Appveyor+    -- can remove once ansi-terminal-0.8 is available in Stackage LTS (which will be v11)+    try_ $ debugPrintTrace trace+    B.writeFile "hoed.json" $ encode trace+#if __GLASGOW_HASKELL__ >= 802+    Just refTrace <- decode <$> B.readFile "test/ref/hoed.json"+#else+    Just refTrace <- decode <$> B.readFile "test/ref/hoed80.json"+#endif+    unless (equivalentTrace trace refTrace) $+      error "Trace does not match the reference value"+    print (foo ['c'])

@@ -1,46 +1,10 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-}--- {-# OPTIONS_GHC -dth-dec-file #-} -- turn on to debug TH  module Main(main) where -import Debug-import Debug.Record-import Control.Exception.Extra--debug [d|-    quicksort :: (a -> a -> Bool) -> [a] -> [a]-    quicksort op [] = []-    quicksort op (x:xs) = quicksort op lt ++ [x] ++ quicksort op gt-        where (lt, gt) = partition (op x) xs--    partition               :: (a -> Bool) -> [a] -> ([a],[a])-    {-# INLINE partition #-}-    partition p xs = foldr (select p) ([],[]) xs--    select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])-    select p x ~(ts,fs) | p x       = (x:ts,fs)-                        | otherwise = (ts, x:fs)-    |]--debug [d|-    foo :: m a -> m a-    foo = id-    |]--quicksort' :: (Ord a, Show a) => [a] -> [a]-quicksort' arg1 = fun "quicksort" $ \t -> quicksort'' t (var t "arg1" arg1)-quicksort'' t [] = []-quicksort'' t ((var t "x" -> x):(var t "xs" -> xs)) = quicksort' lt ++ [x] ++ quicksort' gt-    where (var t "lt" -> lt, var t "gt" -> gt) = partition (<= x) xs+import qualified Hoed+import qualified Variables +main :: IO () main = do-    _ <- return ()-    debugClear-    print $ quicksort (<) "haskell"-    -- see https://github.com/feuerbach/ansi-terminal/issues/47 as this test fails on Appveyor-    try_ debugPrint-    writeFile "trace.js" . ("var trace =\n" ++) . (++ ";") =<< debugJSON-    debugSave "trace.html"-    print $ foo [1]-    print $ quicksort' "haskell"+    Variables.main+    Hoed.main

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+module Util(equivalentTrace) where++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Debug.DebugTrace++equivalentTrace :: DebugTrace -> DebugTrace -> Bool+equivalentTrace tr1 tr2 =+  Set.fromList (functions tr1)  == Set.fromList (functions tr2) &&+  Set.fromList (variables tr1)  == Set.fromList (variables tr2) &&+  Set.fromList (fleshCalls tr1) == Set.fromList (fleshCalls tr2)++data FleshedCallData = FleshedCallData+  { function :: Function+  , depends, parents :: Set FleshedCallData+  , vals :: Set (Text, Text)+  }+  deriving (Eq, Ord)++fleshCalls :: DebugTrace -> [FleshedCallData]+fleshCalls DebugTrace{..} = map fleshCall calls+  where+    result = map fleshCall calls+    sansStack call = call{depends = [], parents = []}+    fleshCall CallData{..} = FleshedCallData{..} where+      function = functions !! callFunctionId+      depends  = Set.fromList $ map (sansStack . (result !!)) callDepends+      parents  = Set.fromList $ map (sansStack . (result !!)) callParents+      vals     = Set.fromList [ (label, variables !! v) | (label,v) <- callVals ]

@@ -0,0 +1,278 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE OverloadedStrings #-}+-- {-# OPTIONS_GHC -dth-dec-file #-} -- turn on to debug TH++module Variables(main) where++import Control.Exception.Extra+import Control.Monad+import Data.List+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Data.Tuple.Extra+import Debug+import Debug.Util+import System.FilePath+import System.Directory+import Debug.DebugTrace++debug [d|+   quicksort :: Ord a => [a] -> [a]+   quicksort [] = []+   quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+       where (lt, gt) = partition (<= x) xs+   |]++quicksort_vars :: [(Text, Text)]+quicksort_vars =+    [ ("$arg1", "\"haskell\"")+    , ("$result", "\"aehklls\"")+    , ("++", "\"aehklls\"")+    , ("++'", "\"hklls\"")+    , ("gt", "\"skll\"")+    , ("lt", "\"ae\"")+    , ("quicksort", "\"ae\"")+    , ("quicksort'", "\"klls\"")+    , ("x", "'h'")+    , ("xs", "\"askell\"") ]++debug [d|+    quicksortBy :: (a -> a -> Bool) -> [a] -> [a]+    quicksortBy op [] = []+    quicksortBy op (x:xs) = quicksortBy op lt ++ [x] ++ quicksortBy op gt+        where (lt, gt) = partitionBy (op x) xs++    partitionBy  :: (a -> Bool) -> [a] -> ([a],[a])+    {-# INLINE partitionBy #-}+    partitionBy p xs = foldr (select p) ([],[]) xs++    select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+    select p x ~(ts,fs) | p x       = (x:ts,fs)+                        | otherwise = (ts, x:fs)+    |]++debug [d|+    type1 :: m a -> m a+    type1 = id++--    type2 :: Int -> m Int+--    type2 _ = undefined+    |]++debug [d|+    lcm_gcd :: (Integral a) => a -> a -> Double+    lcm_gcd x y =+        let least = lcm x y+        in fromIntegral least ^^ gcd x y+    |]++lcm_gcd_vars :: [(Text, Text)]+lcm_gcd_vars =+    [ ("$arg1", "6")+    , ("$arg2", "15")+    , ("$result", "27000.0")+    , ("^^", "27000.0")+    , ("fromIntegral", "30.0")+    , ("gcd", "3")+    , ("lcm", "30")+    , ("least", "30")+    , ("x", "6")+    , ("y", "15") ]++debug [d|+    lcm_gcd_log :: Int -> Int -> Float+    lcm_gcd_log x y =+        let base = fromIntegral $ gcd x y+            val = fromIntegral (x `lcm` y) - base+        in logBase base val ** base+    |]++lcm_gcd_log_vars :: [(Text, Text)]+lcm_gcd_log_vars =+    [ ("$arg1", "6")+    , ("$arg2", "15")+    , ("$result", "27.0")+    , ("**", "27.0")+    , ("-", "27.0")+    , ("base", "3.0")+    , ("fromIntegral", "30.0")+    , ("gcd", "3")+    , ("lcm", "30")+    , ("logBase", "3.0")+    , ("val", "27.0")+    , ("x", "6")+    , ("y", "15") ]++debug [d|+    f :: Int -> Int+    f n = (2 * n) + 1++    case_test :: [Int] -> [Int] -> [Int]+    case_test ys zs =+        case ys of+            x : xs -> f x : xs ++ zs+            [] -> zs+    |]++case_test_vars :: [(Text, Text)]+case_test_vars =+    [ ("$arg1", "[2,3,4]")+    , ("$arg2", "[7,8,9]")+    , ("$result", "[5,3,4,7,8,9]")+    , ("++", "[3,4,7,8,9]")+    , (":", "[5,3,4,7,8,9]")+    , ("f", "5")+    , ("x", "2")+    , ("xs", "[3,4]")+    , ("ys", "[2,3,4]")+    , ("zs", "[7,8,9]") ]++debug [d|+    twoXs :: [Int] -> [Int] -> [Int]+    twoXs x y =+        case x of+            x : xs -> f x : xs ++ y+            [] -> y+    |]++twoXs_vars :: [(Text, Text)]+twoXs_vars =+    [ ("$arg1", "[2,3,4]")+    , ("$arg2", "[7,8,9]")+    , ("$result", "[5,3,4,7,8,9]")+    , ("++", "[3,4,7,8,9]")+    , (":", "[5,3,4,7,8,9]")+    , ("f", "5")+    , ("x", "[2,3,4]")+    , ("x'", "2")+    , ("xs", "[3,4]")+    , ("y", "[7,8,9]") ]++debug [d|+    --barely comprehensible test with multiple values for x and xs+    manyXs :: [Int] -> [Int] -> [Int]+    manyXs x y =+        case x of+            x : xs ->+                f x : case xs of+                    x : xs -> f x : xs ++ y+                    [] -> y+            [] -> y+    |]++manyXs_vars :: [(Text, Text)]+manyXs_vars =+    [ ("$arg1", "[2,3,4]")+    , ("$arg2", "[7,8,9]")+    , ("$result", "[5,7,4,7,8,9]")+    , ("++", "[4,7,8,9]")+    , (":", "[5,7,4,7,8,9]")+    , (":'", "[7,4,7,8,9]")+    , ("f", "5")+    , ("f'", "7")+    , ("x", "[2,3,4]")+    , ("x'", "2")+    , ("x''", "3")+    , ("xs", "[3,4]")+    , ("xs'", "[4]")+    , ("y", "[7,8,9]") ]++explicit :: (Ord a, Show a) => [a] -> [a]+explicit = quicksort'+    where+        quicksort' arg1 = fun "quicksort" $ \t -> quicksort'' t (var t "arg1" arg1)+        quicksort'' t [] = []+        quicksort'' t ((var t "x" -> x):(var t "xs" -> xs)) = quicksort' lt ++ [x] ++ quicksort' gt+            where (var t "lt" -> lt, var t "gt" -> gt) = partition (<= x) xs++testExample name expr testDisabled = do+    _ <- return ()+    putStrLn $ "Testing " ++ name+    debugClear+    print expr+    unless testDisabled $+        checkVars name expr+    writeFile ("output" </> name <.> "js") . ("var trace =\n" ++) . (++ ";") =<< debugJSON+    debugSave $ "output" </> name <.> "html"+    -- see https://github.com/feuerbach/ansi-terminal/issues/47 as this test fails on Appveyor+    -- can remove once ansi-terminal-0.8 is available in Stackage LTS (which will be v11)+    try_ debugPrint+    putStrLn "\n\n"++checkVars :: Show a => String -> a -> IO ()+checkVars name expr = do+    trace <- getDebugTrace+    let varList = map (first funName) $ getTraceVars trace+    case lookup (pack name) varList of+        Nothing -> fail $ "Cant find the function " ++ name ++ " in the trace"+        Just vars ->+            case lookup name expectedVars of+                Nothing -> fail $ "Can't find the list of expected variables for the function " ++ name+                Just expected -> case checkEachVar vars expected of+                    [] -> do+                        when (length vars /= length expected) $+                            fail $ "Expected " ++ show (length expected) ++ " variables, but found " ++ show (length vars)+                        return ()+                    xs -> fail $ "\n" ++ unlines xs++checkEachVar :: [(Text, Text)] -> [(Text, Text)] -> [String]+checkEachVar vars expected = foldr f [] vars where+    f :: (Text, Text) -> [String] -> [String]+    f (key, val) acc =+        case lookup key expected of+            Nothing -> ("Couldn't find the variable " ++ T.unpack key ++ " in the expected results") : acc+            Just v -> if v /= val+                then ("Expected " ++ unpack val ++ " but got " ++ unpack v ++ " for the variable " ++ unpack key) : acc+                else acc++expectedVars :: [(String, [(Text, Text)])]+expectedVars = [ ("quicksort", quicksort_vars)+               , ("lcm_gcd", lcm_gcd_vars)+               , ("lcm_gcd_log", lcm_gcd_log_vars)+               , ("case_test", case_test_vars)+               , ("twoXs", twoXs_vars)+               , ("manyXs", manyXs_vars) ]++main = do+    createDirectoryIfMissing True "output"+    testExample "quicksort" (quicksort "haskell") False+    testExample "lcm_gcd" (lcm_gcd 6 15) False+    testExample "lcm_gcd_log" (lcm_gcd_log 6 15) False+    testExample "case_test" (case_test [2,3,4] [7,8,9]) False+    testExample "twoXs" (twoXs [2,3,4] [7,8,9]) False+    testExample "manyXs" (manyXs [2,3,4] [7,8,9]) False++    --skipping test of quicksortBy for now, as it looks like $arg1 is missing+    testExample "quicksortBy" (quicksortBy (<) "haskell") True+    testExample "explicit" (explicit "haskell") True+    copyFile "output/quicksort.js" "trace.js" -- useful for debugging the HTML++    evaluate type1+--    evaluate type2++    let a === b = if a == b then putStr "." else fail $ show (a, "/=", b)+    removeExtraDigits "_quicksort_0" === "_quicksort"+    removeLet let0 === "f"+    removeLet let1 === "select_2"+    removeLet let2 === "Data.Foldable.foldr"+    removeLet let3 === "Data.Foldable.foldr"+    mkLegalInfixVar "+" === "plus"+    mkLegalInfixVar "<!>" === "lt_bang_gt"+    mkLegalInfixVar "`lcd`" === "lcd"+    mkLegalInfixVar "abc" === "abc"++    putStrLn " done"++let0, let1, let2 :: String+let0 = "f"+let1 = "let (Debug.DebugTrace.var tag_0 \"_select_0\" -> _select_0_1) = select_2 p_3"+let2 = "let (Debug.DebugTrace.var tag_0 \"_foldr\" -> _foldr_1) = Data.Foldable.foldr \+        \(let (Debug.DebugTrace.var tag_0 \"_select_0\" -> _select_0_2) = select_3 p_4 \+        \in _select_0_2)"+let3 = "let (Debug.DebugTrace.var tag_0 \"_foldr'\" -> _foldr'_1) = (let (Debug.DebugTrace.var \tag_0 \+       \\"_foldr\" -> _foldr_2) = Data.Foldable.foldr (let (Debug.DebugTrace.var tag_0 \"_select_0\" \+       \-> _select_0_3) = select_4 p_5 in _select_0_3) in _foldr_2) ([], []) \+       \in _foldr'_1"

@@ -0,0 +1,1 @@+{"functions":[{"name":"listcomp","source":"\nlistcomp y = sum [x * 2 | x <- [1..y]]","arguments":["$arg1"],"result":"$result"},{"name":"listmap","source":"\nlistmap y = sum $ map (\\x -> 1 + (x * 2)) [1..y]","arguments":["$arg1"],"result":"$result"},{"name":"partition","source":"\npartition p = foldr (select p) ([], [])","arguments":["$arg1","$arg2"],"result":"$result"},{"name":"quicksort","source":"\nquicksort op ([]) = []\nquicksort op (x : xs) = quicksort op lt ++ ([x] ++ quicksort op gt)\n              where (lt, gt) = partition (op x) xs","arguments":["$arg1","$arg2"],"result":"$result"},{"name":"quicksort","source":"\nquicksort op ([]) = []\nquicksort op (x : xs) = quicksort op lt ++ ([x] ++ quicksort op gt)\n              where (lt, gt) = partition (op x) xs","arguments":["$arg1","$arg2","gt","lt"],"result":"$result"},{"name":"select","source":"\nselect p x (~(ts, fs)) | p x = (x : ts, fs)\n                       | otherwise = (ts, x : fs)","arguments":["$arg1"],"result":"$result"},{"name":"select","source":"\nselect p x (~(ts, fs)) | p x = (x : ts, fs)\n                       | otherwise = (ts, x : fs)","arguments":["$arg1","$arg2","$arg3"],"result":"$result"}],"variables":["\"l\"","'l'","\"ea\"","15","{ \\ 'l' (\"l\", [])  -> (\"ll\", [])\n, \\ 'l' ([], [])  -> (\"l\", [])\n}","\"ae\"","\"askell\"","{ \\ 'l'  -> False\n}","\"e\"","([], [])","'e'","\"ll\"","\"sllk\"","{ \\ 'e'  -> True\n}","\"skll\"","12","[]","{ \\ 'a'  -> False\n, \\ 'e'  -> False\n, \\ 'k'  -> True\n, \\ 'l'  -> True\n, \\ 'l'  -> True\n, \\ 's'  -> True\n}","{ \\ 'a' 'e'  -> True\n}","(\"skll\", \"ae\")","\"sllkhea\"","\"haskell\"","_","{ \\ 'a' 'e'  -> True\n, \\ 'h'  -> { \\ 'a'  -> False\n   , \\ 'e'  -> False\n   , \\ 'k'  -> True\n   , \\ 'l'  -> True\n   , \\ 'l'  -> True\n   , \\ 's'  -> True\n   }\n, \\ 'k'  -> { \\ 'l'  -> True , \\ 'l'  -> True }\n, \\ 'l' 'l'  -> False\n, \\ 's'  -> { \\ 'k'  -> False , \\ 'l'  -> False , \\ 'l'  -> False }\n}","([], \"l\")","{ \\ 'l'  -> True\n, \\ 'l'  -> True\n}","{ \\ 'a' (\"skll\", \"e\")  -> (\"skll\", \"ae\")\n, \\ 'e' (\"ll\", [])  -> (\"ll\", \"e\")\n, \\ 'k' (\"ll\", \"e\")  -> (\"kll\", \"e\")\n, \\ 'l' (\"l\", [])  -> (\"ll\", [])\n, \\ 'l' ([], [])  -> (\"l\", [])\n, \\ 's' (\"kll\", \"e\")  -> (\"skll\", \"e\")\n}","{ \\ 'k' ([], \"ll\")  -> ([], \"kll\")\n, \\ 'l' ([], \"l\")  -> ([], \"ll\")\n, \\ 'l' ([], [])  -> ([], \"l\")\n}","{ \\ 'k'  -> False\n, \\ 'l'  -> False\n, \\ 'l'  -> False\n}","([], \"kll\")","\"kll\"","\"llk\"","3","(\"ll\", [])","{ \\ 'k'  -> { \\ 'l'  -> True , \\ 'l'  -> True }\n, \\ 'l' 'l'  -> False\n, \\ 's'  -> { \\ 'k'  -> False , \\ 'l'  -> False , \\ 'l'  -> False }\n}","{ \\ 'l' 'l'  -> False\n}","{ \\ 'k'  -> { \\ 'l'  -> True , \\ 'l'  -> True }\n, \\ 'l' 'l'  -> False\n}","(\"e\", [])"],"calls":[{"":0,"$result":15,"$arg1":32},{"":1,"$result":3,"$arg1":32},{"":2,"$depends":[24],"$parents":[17],"$result":19,"$arg1":17,"$arg2":6},{"":2,"$depends":[25],"$parents":[18],"$result":29,"$arg1":28,"$arg2":30},{"":2,"$depends":[26],"$parents":[19],"$result":33,"$arg1":25,"$arg2":11},{"":2,"$depends":[27],"$parents":[20],"$result":24,"$arg1":7,"$arg2":0},{"":2,"$parents":[21],"$result":9,"$arg1":22,"$arg2":16},{"":2,"$depends":[28],"$parents":[22],"$result":37,"$arg1":13,"$arg2":8},{"":2,"$parents":[23],"$result":9,"$arg1":22,"$arg2":16},{"":3,"$parents":[18],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[20],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[21],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[21],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[19],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[23],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[23],"$result":16,"$arg1":22,"$arg2":16},{"":3,"$parents":[22],"$result":16,"$arg1":22,"$arg2":16},{"":4,"$depends":[18,2,22],"$result":20,"$arg1":23,"$arg2":21,"gt":5,"lt":14},{"":4,"$depends":[9,3,19],"$parents":[17],"$result":12,"$arg1":34,"$arg2":14,"gt":30,"lt":16},{"":4,"$depends":[20,4,13],"$parents":[18],"$result":31,"$arg1":36,"$arg2":30,"gt":16,"lt":11},{"":4,"$depends":[10,5,21],"$parents":[19],"$result":11,"$arg1":35,"$arg2":11,"gt":0,"lt":16},{"":4,"$depends":[11,6,12],"$parents":[20],"$result":0,"$arg1":22,"$arg2":0,"gt":16,"lt":16},{"":4,"$depends":[23,7,16],"$parents":[17],"$result":2,"$arg1":18,"$arg2":5,"gt":16,"lt":8},{"":4,"$depends":[14,8,15],"$parents":[22],"$result":8,"$arg1":22,"$arg2":8,"gt":16,"lt":16},{"":5,"$parents":[2],"$result":26,"$arg1":17},{"":5,"$parents":[3],"$result":27,"$arg1":28},{"":5,"$parents":[4],"$result":4,"$arg1":25},{"":6,"$parents":[5],"$result":24,"$arg1":7,"$arg2":1,"$arg3":9},{"":6,"$parents":[7],"$result":37,"$arg1":13,"$arg2":10,"$arg3":9}]}

@@ -0,0 +1,1 @@+{"functions":[{"name":"listcomp","source":"\nlistcomp y = sum [x * 2 | x <- [1..y]]","arguments":["$arg1"],"result":"$result"},{"name":"listmap","source":"\nlistmap y = sum $ map (\\x -> 1 + (x * 2)) [1..y]","arguments":["$arg1"],"result":"$result"}],"variables":["15","12","3"],"calls":[{"":0,"$result":1,"$arg1":2},{"":1,"$result":0,"$arg1":2}]}