Debug.hs

{-

This file contains useful functions for debugging and developing ShellCheck.

To invoke them interactively, run:

    cabal repl

At the ghci prompt, enter:

    :load ShellCheck.Debug

You can now invoke the functions. Here are some examples:

    shellcheckString "echo $1"
    stringToAst "(( x+1 ))"
    stringToCfg "if foo; then bar; else baz; fi"
    writeFile "/tmp/test.dot" $ stringToCfgViz "while foo; do bar; done"

The latter file can be rendered to png with GraphViz:

    dot -Tpng /tmp/test.dot > /tmp/test.png

To run all unit tests in a module:

    ShellCheck.Parser.runTests
    ShellCheck.Analytics.runTests

To run a specific test:

    :load ShellCheck.Analytics
    prop_checkUuoc3

If you make code changes, reload in seconds at any time with:

    :r

===========================================================================

Crash course in printf debugging in Haskell:

    import Debug.Trace

    greet 0 = return ()
    -- Print when a function is invoked
    greet n | trace ("calling greet " ++ show n) False = undefined
    greet n = do
        putStrLn "Enter name"
        name <- getLine
        -- Print at some point in any monadic function
        traceM $ "user entered " ++ name
        putStrLn $ "Hello " ++ name
        -- Print a value before passing it on
        greet $ traceShowId (n - 1)


===========================================================================

If you want to invoke `ghci` directly, such as on `shellcheck.hs`, to
debug all of ShellCheck including I/O, you may see an error like this:

    src/ShellCheck/Data.hs:5:1: error:
        Could not load module ‘Paths_ShellCheck’
    it is a hidden module in the package ‘ShellCheck-0.8.0’

This can easily be circumvented by running `./setgitversion` or manually
editing src/ShellCheck/Data.hs to replace the auto-deduced version number
with a constant string as indicated.

Afterwards, you can run the ShellCheck tool, as if from the shell, with:

    $ ghci shellcheck.hs
    ghci> runMain ["-x", "file.sh"]

-}

module ShellCheck.Debug () where

import ShellCheck.Analyzer
import ShellCheck.AST
import ShellCheck.CFG
import ShellCheck.Checker
import ShellCheck.CFGAnalysis as CF
import ShellCheck.Interface
import ShellCheck.Parser
import ShellCheck.Prelude

import Control.Monad
import Control.Monad.Identity
import Control.Monad.RWS
import Control.Monad.Writer
import Data.Graph.Inductive.Graph as G
import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S


-- Run all of ShellCheck (minus output formatters)
shellcheckString :: String -> CheckResult
shellcheckString scriptString =
    runIdentity $ checkScript dummySystemInterface checkSpec
  where
    checkSpec :: CheckSpec
    checkSpec = emptyCheckSpec {
        csScript = scriptString
    }

dummySystemInterface :: SystemInterface Identity
dummySystemInterface = mockedSystemInterface [
    -- A tiny, fake filesystem for sourced files
    ("lib/mylib1.sh", "foo=$(cat $1 | wc -l)"),
    ("lib/mylib2.sh", "bar=42")
    ]

-- Parameters used when generating Control Flow Graphs
cfgParams :: CFGParameters
cfgParams = CFGParameters {
    cfLastpipe = False,
    cfPipefail = False
}

-- An example script to play with
exampleScript :: String
exampleScript = unlines [
    "#!/bin/sh",
    "count=0",
    "for file in *",
    "do",
    "  (( count++ ))",
    "done",
    "echo $count"
    ]

-- Parse the script string into ShellCheck's ParseResult
parseScriptString :: String -> ParseResult
parseScriptString scriptString =
    runIdentity $ parseScript dummySystemInterface parseSpec
  where
    parseSpec :: ParseSpec
    parseSpec = newParseSpec {
        psFilename = "myscript",
        psScript = scriptString
    }


-- Parse the script string into an Abstract Syntax Tree
stringToAst :: String -> Token
stringToAst scriptString =
    case maybeRoot of
        Just root -> root
        Nothing -> error $ "Script failed to parse: " ++ show parserWarnings
  where
    parseResult :: ParseResult
    parseResult = parseScriptString scriptString

    maybeRoot :: Maybe Token
    maybeRoot = prRoot parseResult

    parserWarnings :: [PositionedComment]
    parserWarnings = prComments parseResult


astToCfgResult :: Token -> CFGResult
astToCfgResult = buildGraph cfgParams

astToDfa :: Token -> CFGAnalysis
astToDfa = analyzeControlFlow cfgParams

astToCfg :: Token -> CFGraph
astToCfg = cfGraph . astToCfgResult

stringToCfg :: String -> CFGraph
stringToCfg = astToCfg . stringToAst

stringToDfa :: String -> CFGAnalysis
stringToDfa = astToDfa . stringToAst

cfgToGraphViz :: CFGraph -> String
cfgToGraphViz = cfgToGraphVizWith show

stringToCfgViz :: String -> String
stringToCfgViz = cfgToGraphViz . stringToCfg

stringToDfaViz :: String -> String
stringToDfaViz = dfaToGraphViz . stringToDfa

-- Dump a Control Flow Graph as GraphViz with extended information
stringToDetailedCfgViz :: String -> String
stringToDetailedCfgViz scriptString = cfgToGraphVizWith nodeLabel graph
  where
    ast :: Token
    ast = stringToAst scriptString

    cfgResult :: CFGResult
    cfgResult = astToCfgResult ast

    graph :: CFGraph
    graph = cfGraph cfgResult

    idToToken :: M.Map Id Token
    idToToken = M.fromList $ execWriter $ doAnalysis (\c -> tell [(getId c, c)]) ast

    idToNode :: M.Map Id (Node, Node)
    idToNode = cfIdToRange cfgResult

    nodeToStartIds :: M.Map Node (S.Set Id)
    nodeToStartIds =
        M.fromListWith S.union $
            map (\(id, (start, _)) -> (start, S.singleton id)) $
                M.toList idToNode

    nodeToEndIds :: M.Map Node (S.Set Id)
    nodeToEndIds =
        M.fromListWith S.union $
            map (\(id, (_, end)) -> (end, S.singleton id)) $
                M.toList idToNode

    formatId :: Id -> String
    formatId id = fromMaybe ("Unknown " ++ show id) $ do
        (OuterToken _ token) <- M.lookup id idToToken
        firstWord <- words (show token) !!! 0
        -- Strip off "Inner_"
        (_ : tokenName) <- return $ dropWhile (/= '_') firstWord
        return $ tokenName ++ " " ++ show id

    formatGroup :: S.Set Id -> String
    formatGroup set = intercalate ", " $ map formatId $ S.toList set

    nodeLabel (node, label) = unlines [
        show node ++ ". " ++ show label,
        "Begin: " ++ formatGroup (M.findWithDefault S.empty node nodeToStartIds),
        "End: " ++ formatGroup (M.findWithDefault S.empty node nodeToEndIds)
        ]


-- Dump a Control Flow Graph with Data Flow Analysis as GraphViz
dfaToGraphViz :: CF.CFGAnalysis -> String
dfaToGraphViz analysis = cfgToGraphVizWith label $ CF.graph analysis
  where
    label (node, label) =
        let
            desc = show node ++ ". " ++ show label
        in
            fromMaybe ("No DFA available\n\n" ++ desc) $ do
                (pre, post) <- M.lookup node $ CF.nodeToData analysis
                return $ unlines [
                    "Precondition: " ++ show pre,
                    "",
                    desc,
                    "",
                    "Postcondition: " ++ show post
                    ]


-- Dump an Control Flow Graph to GraphViz with a given node formatter
cfgToGraphVizWith :: (LNode CFNode -> String) -> CFGraph -> String
cfgToGraphVizWith nodeLabel graph = concat [
    "digraph {\n",
    concatMap dumpNode (labNodes graph),
    concatMap dumpLink (labEdges graph),
    tagVizEntries graph,
    "}\n"
    ]
  where
    dumpNode l@(node, label) = show node ++ " [label=" ++ quoteViz (nodeLabel l) ++ "]\n"
    dumpLink (from, to, typ) = show from ++ " -> " ++ show to ++ " [style=" ++ quoteViz (edgeStyle typ)  ++ "]\n"
    edgeStyle CFEFlow = "solid"
    edgeStyle CFEExit = "bold"
    edgeStyle CFEFalseFlow = "dotted"

quoteViz str = "\"" ++ escapeViz str ++ "\""
escapeViz [] = []
escapeViz (c:rest) =
    case c of
        '\"' -> '\\' : '\"' : escapeViz rest
        '\n' -> '\\' : 'l' : escapeViz rest
        '\\' -> '\\' : '\\' : escapeViz rest
        _ -> c : escapeViz rest


-- Dump an Abstract Syntax Tree (or branch thereof) to GraphViz format
astToGraphViz :: Token -> String
astToGraphViz token = concat [
    "digraph {\n",
    formatTree token,
    "}\n"
    ]
  where
    formatTree :: Token -> String
    formatTree t = snd $ execRWS (doStackAnalysis push pop t) () []

    push :: Token -> RWS () String [Int] ()
    push (OuterToken (Id n) inner) = do
        stack <- get
        put (n : stack)
        case stack of
            [] -> return ()
            (top:_) -> tell $ show top ++ " -> " ++ show n ++ "\n"
        tell $ show n ++ " [label=" ++ quoteViz (show n ++ ": " ++ take 32 (show inner)) ++ "]\n"

    pop :: Token -> RWS () String [Int] ()
    pop _ = modify tail


-- For each entry point, set the rank so that they'll align in the graph
tagVizEntries :: CFGraph -> String
tagVizEntries graph = "{ rank=same " ++ rank ++ " }"
  where
    entries = mapMaybe find $ labNodes graph
    find (node, CFEntryPoint name) = return (node, name)
    find _ = Nothing
    rank = unwords $ map (\(c, _) -> show c) entries