debug-0.1: src/DebugPP.hs
{-# 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