debug-pp 0.1.0.0 → 0.1.1
raw patch · 3 files changed
+218/−26 lines, 3 filesdep +aesondep +debug-hoeddep +directory
Dependencies added: aeson, debug-hoed, directory, filepath, yaml
Files
- README.md +29/−1
- debug-pp.cabal +15/−4
- src/Main.hs +174/−21
README.md view
@@ -40,7 +40,35 @@ ... build-tool-depends: debug-pp:debug-pp ```+Configuration+------------- +The tool is customizable to some extent. It tries to find a config file in the+following order:++2. `.debug-pp.yaml` in the current directory (useful for per-directory+ settings)+3. `.debug-pp.yaml` in the nearest ancestor directory (useful for+ per-project settings)+4. `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)+5. `.debug-pp.yaml` in your home directory (useful for user-wide+ settings)+6. 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 to launch a web browser upon completion.+* Select which language extensions are included automatically.+* Configure the `debug-hoed` instrumentation to include e.g. deriving `Generic` and `Observable` instances++ Motivation ------------- @@ -48,4 +76,4 @@ * However, error messages are much worse for TH quoted code. Errors like `Not in scope: data constructor Foo in line X` become `Not in scope: Foo, in the TH quotation ENTIRE MODULE HERE`. -* Personally, quoting/unquoting the module by hand is annoying. Having a preprocessor do this for me is convenient, and can be easily tied to a Cabal flag ora stack command line arg.+* Personally, quoting/unquoting the module by hand is annoying. Having a preprocessor do this for me is convenient, and can be easily tied to a Cabal flag or a stack command line arg.
debug-pp.cabal view
@@ -2,13 +2,15 @@ -- -- see: https://github.com/sol/hpack ----- hash: 961f3a1ce57f79aa77bfe78b26a463a2bab8121dbb2e495de793608f4dc714e4+-- hash: 2fdefebfe7db959b89432facceefb61718e6546123aa7074c20c8bbe9e31ab06 name: debug-pp-version: 0.1.0.0-description: A preprocessor to automate the debug instrumentation of a module+version: 0.1.1+synopsis: A preprocessor for the debug package+description: A preprocessor to automate the instrumentation of a module for the debug package category: Debugging homepage: https://github.com/pepeiborra/debug-hoed-pp#readme+bug-reports: https://github.com/pepeiborra/debug-pp/issues author: Pepe Iborra maintainer: pepeiborra@gmail.com copyright: All Rights Reserved@@ -20,12 +22,21 @@ extra-source-files: README.md +source-repository head+ type: git+ location: https://github.com/pepeiborra/debug-pp+ executable debug-pp main-is: Main.hs hs-source-dirs: src build-depends:- base >=4.7 && <5+ aeson+ , base >=4.7 && <5+ , debug-hoed+ , directory+ , filepath+ , yaml other-modules: Paths_debug_pp default-language: Haskell2010
src/Main.hs view
@@ -1,12 +1,23 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ViewPatterns #-} module Main (main) where import Control.Monad+import Data.Aeson import Data.Char import Data.List+import Data.Maybe+import Data.Yaml+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 @@ -21,11 +32,98 @@ "If no SOURCE or if SOURCE is `-', read standard input." ] +data Config = Config_+ { _excluded :: Maybe [String]+ , _instrumentMain :: Maybe Bool+ , _disablePartialTypeSignatureWarnings :: Maybe Bool+ , _enableExtendedDefaultingRules :: Maybe Bool+ , _generateObservableInstances :: Maybe Bool+ , _generateGenericInstances :: Maybe Bool+ , _excludedFromInstanceGeneration :: Maybe [String]+ , _verbose :: Maybe Bool+ } deriving (Generic, Show)++configJsonOptions = defaultOptions{fieldLabelModifier = tail}++instance FromJSON Config where parseJSON = genericParseJSON configJsonOptions+instance ToJSON Config where toJSON = genericToJSON configJsonOptions+++pattern Config { excluded+ , instrumentMain+ , disablePartialTypeSignatureWarnings+ , enableExtendedDefaultingRules+ , generateGenericInstances+ , generateObservableInstances+ , excludedFromInstanceGeneration+ , verbose+ } <-+ Config_+ { _excluded = (fromMaybe [] -> excluded)+ , _instrumentMain = (fromMaybe True -> instrumentMain)+ , _disablePartialTypeSignatureWarnings = (fromMaybe True -> disablePartialTypeSignatureWarnings)+ , _enableExtendedDefaultingRules = (fromMaybe False -> enableExtendedDefaultingRules)+ , _generateObservableInstances = (fromMaybe False -> generateObservableInstances)+ , _generateGenericInstances = (fromMaybe False -> generateGenericInstances)+ , _excludedFromInstanceGeneration = (fromMaybe [] -> excludedFromInstanceGeneration)+ , _verbose = (fromMaybe False -> verbose)+ }+ where Config a b c d e f g h = Config_ (Just a) (Just b) (Just c) (Just d) (Just e) (Just f) (Just g) (Just h)++defaultConfig :: Config+defaultConfig = Config_ 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 = unlines+ ["# debug-pp configuration file"+ ,"# ==========================="+ ,""+ ,"# List of Haskell module names to exclude from instrumentation"+ ,"excluded: []"+ , ""+ , "# If true then insert a call to debugRun in the main function."+ , "instrumentMain: true"+ , ""+ , "# If true, instruct the debug TH wrapper to insert Observable instances for types that derive Generic."+ , "generateGenericInstances: false"+ , ""+ , "# If true, instruct the debug TH wrapper to insert Generic instances for types that don't derive Generic."+ , "generateGenericInstances: false"+ , ""+ , "# List of types excluded from instance generation"+ , "excludedFromInstanceGeneration: []"+ , ""+ , "# If true, print a line for every instrumented module."+ , "verbose: false"+ , ""+ , "# If true, enable GHC extended defaulting rules. This is often required when using debug-hoed"+ , "enableExtendedDefaultingRules: true"+ , ""+ , ""+ ]+ 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@@ -39,39 +137,94 @@ hIn <- maybe (return stdin) (`openFile` ReadMode) inp hOut <- maybe (return stdout) (`openFile` WriteMode) out contents <- hGetContents hIn- hPutStr hOut $ instrument contents+ config@Config{..} <- readConfig+ hPutStr hOut $ instrument config contents unless (hOut == stdout) $ hClose hOut+ when verbose $+ putStrLn $ "[debug-pp] Instrumented " ++ orig -instrument contents = unlines [top', modules', body']+instrument Config {..} contents+ | name `elem` excluded = contents+ | otherwise = unlines [top', modules', body''] where- (top,modules,body) = parseModule contents- modules' = unlines $ modules ++ ["import qualified Debug"]+ (top, name, modules, body) = parseModule contents+ modules' = unlines $ modules +++ ["import qualified Debug"] +++ ["import qualified GHC.Generics" | generateGenericInstances] top' =- unlines- $ "{-# LANGUAGE TemplateHaskell #-}"- : "{-# LANGUAGE PartialTypeSignatures #-}"- : "{-# LANGUAGE ViewPatterns #-}"- : "{-# OPTIONS -Wno-partial-type-signatures #-}"- : top- body' = unlines $ "Debug.debug [d|" : map indent (body ++ [" |]"])+ unlines $+ [ "{-# LANGUAGE TemplateHaskell #-}"+ , "{-# LANGUAGE PartialTypeSignatures #-}"+ , "{-# LANGUAGE ViewPatterns #-}"+ , "{-# LANGUAGE FlexibleContexts #-}"+ ] +++ [ "{-# OPTIONS -Wno-partial-type-signatures #-}"+ | disablePartialTypeSignatureWarnings+ ] +++ ["{-# LANGUAGE ExtendedDefaultRules #-}" | enableExtendedDefaultingRules] +++ ["{-# LANGUAGE DeriveAnyClass #-}" | generateObservableInstances] +++ ["{-# LANGUAGE DerivingStrategies #-}" | generateObservableInstances] +++ ["{-# LANGUAGE DeriveGeneric #-}" | generateGenericInstances] ++ top+ body' =+ map+ (if instrumentMain+ then instrumentMainFunction+ else id)+ body+ debugWrapper+ | not (generateGenericInstances || generateObservableInstances) =+ "Debug.debug"+ | otherwise =+ printf+ "Debug.debug' Debug.Config{Debug.generateGenericInstances=%s,Debug.generateObservableInstances=%s, Debug.excludeFromInstanceGeneration=%s}"+ (show generateGenericInstances)+ (show generateObservableInstances)+ (show excludedFromInstanceGeneration)+ body'' = unlines $ (debugWrapper ++ " [d|") : map indent (body' ++ [" |]"]) -parseModule contents = (top, modules, body)+instrumentMainFunction l+ | ('m':'a':'i':'n':rest) <- l+ , ('=':rest') <- dropWhile isSpace rest+ , not ("debugRun" `isPrefixOf` rest') = "main = Debug.debugRun $ " ++ rest'+ | otherwise = l++parseModule contents = (map fst top, name, modules, body) where- isImportLine = ("import" `isPrefixOf`)- (top, rest) = break isImportLine (lines contents)- (reverse -> body0, reverse -> modules0) =- break (isImportLine . fst) (reverse $ annotateBlockComments rest)+ contents' = annotateBlockComments (lines contents)+ isImportLine = ("import " `isPrefixOf`)+ (top, rest) = break (\(l, insideComment) -> not insideComment && isImportLine l) contents'+ (reverse -> body0, reverse -> modules0) = break (\(l,insideComment) -> not insideComment && isImportLine l) (reverse rest)+ nameLine =+ head $+ [l | (l, False) <- top, "module " `isPrefixOf` l] +++ ["Main"]+ name = takeWhile (\x -> not (isSpace x || x == '(')) $ drop 7 nameLine body = map fst $ dropWhile snd body0 modules = map fst modules0 ++ map fst (takeWhile snd body0) 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' _ [] = []-annotateBlockComments' False (l:rest)- | "{-" `isInfixOf` l = (l,True) : annotateBlockComments' True rest- | otherwise = (l,False) : annotateBlockComments' False rest-annotateBlockComments' True (l:rest) =- (l,True) : annotateBlockComments' (not $ "-}" `isInfixOf` l) rest+annotateBlockComments' False (l:rest) = (l,False) : annotateBlockComments' (startsBlockComment l) rest+annotateBlockComments' True (l:rest) = (l,True) : annotateBlockComments' (not $ endsBlockComment l) rest++startsBlockComment line+ | Just l' <- dropUntilIncluding "{-" line = not $ endsBlockComment l'+ | otherwise = False++endsBlockComment line+ | Just l' <- dropUntilIncluding "-}" line = not $ startsBlockComment l'+ | otherwise = False++dropUntilIncluding needle haystack+ | [] <- haystack = Nothing+ | Just x <- stripPrefix needle haystack = Just x+ | x:rest <- haystack = (x:) <$> dropUntilIncluding needle rest