vampire 0.1.0.0 → 0.1.1.0

raw patch · 3 files changed

+64/−14 lines, 3 filesdep +optparse-applicative

Dependencies added: optparse-applicative

Files

• Debug/Vampire/Rewrite.hs +28/−0
• Main.hs +30/−11
• vampire.cabal +6/−3

@@ -0,0 +1,28 @@+module Debug.Vampire.Rewrite (rewriteFile) where++import Language.Haskell.Exts+import Data.Generics.Uniplate.Data (descend, descendBi)++rewriteFile :: String -> Maybe String+rewriteFile code =+  case parse code :: ParseResult Module of+    ParseOk mod -> Just $ prettyPrint $ addHeader $ descendBi rewrite mod+    _           -> Nothing++addHeader :: Module -> Module+addHeader (Module loc name prag warn exports imports decls) =+  Module loc name (implicit:prag) warn exports (trace:imports) decls+    where implicit = LanguagePragma (SrcLoc {srcFilename = "<unknown>.hs", srcLine = 1, srcColumn = 1}) [Ident "ImplicitParams"]+          trace    = ImportDecl {importLoc = SrcLoc {srcFilename = "<unknown>.hs", srcLine = 5, srcColumn = 1}, importModule = ModuleName "Debug.Vampire.Trace", importQualified = False, importSrc = False, importPkg = Nothing, importAs = Nothing, importSpecs = Nothing}++-- TODO: replace ugly pasted literal with something more sensible+rewrite :: Exp -> Exp+rewrite exp = Let (BDecls [PatBind (SrcLoc {srcFilename = "<unknown>.hs", srcLine = 1, srcColumn = 5}) (PVar (Ident "vResultStruct")) Nothing (UnGuardedRhs (App (Var (UnQual (Ident "vNewExprStruct"))) (Lit (String (prettyPrint exp))))) (BDecls []),PatBind (SrcLoc {srcFilename = "<unknown>.hs", srcLine = 2, srcColumn = 5}) (PVar (Ident "vResult")) Nothing (UnGuardedRhs (Paren (Let (BDecls [PatBind (SrcLoc {srcFilename = "<unknown>.hs", srcLine = 2, srcColumn = 21}) (PVar (Ident "?vCtx")) Nothing (UnGuardedRhs (Var (UnQual (Ident "vResultStruct")))) (BDecls [])]) (descend rewrite exp)))) (BDecls [])]) (App (App (App (Var (UnQual (Ident "vLog"))) (Var (UnQual (Ident "?vCtx")))) (Var (UnQual (Ident "vResult")))) (Var (UnQual (Ident "vResultStruct"))))++{-+rewrite expr = AST for this:+  let resultStruct = newExprStruct+      result = (let ?ctx = resultStruct in [splice expr in])+  in (log ?ctx result resultStruct) `seq` result+-}+

@@ -1,16 +1,35 @@ module Main where  import Debug.Vampire-import System.Environment-import Data.Functor+import Options.Applicative+import Control.Applicative+import Control.Monad+import System.Exit -main = do-  args <- getArgs-  case args of-    fn:_ -> do-      newCode <- rewriteFile <$> readFile fn-      case newCode of-        Just code -> putStrLn code-        Nothing -> putStrLn "Invalid syntax in file!"-    [] -> putStrLn "Need a filename!"+readFrom "-"  = getContents+readFrom file = readFile file+writeTo  "-"  = putStrLn+writeTo  file = writeFile file++doRewrite :: String -> String -> IO ()+doRewrite src dest = do+  code <- readFrom src+  case rewriteFile code of+    Just newCode -> writeTo dest newCode+    Nothing      -> putStrLn "could not parse input" >> exitFailure++-- parsers!++rewrite =+  liftA2 doRewrite+    (argument str $ metavar "SOURCE")+    (argument str $ metavar "DEST" <> value "-" <> showDefault)+rewriteDesc = "Rewrite a Haskell source file to add Vampire tracing."+ +vampire = subparser $+  (command "rewrite" $ info rewrite $ progDesc rewriteDesc)++main = join $ execParser $+  info (helper <*> vampire)+  (fullDesc <> header "vampire - eeevil expression tree analysis") 

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.0.0+version:             0.1.1.0  -- A short (one-line) description of the package. synopsis:            Analyze and visualize expression trees.@@ -55,6 +55,7 @@    other-modules:     Debug.Vampire.Data+    Debug.Vampire.Rewrite     Debug.Vampire.Visualize    build-depends:@@ -65,7 +66,8 @@     fgl,     mtl,     dlist,-    graphviz+    graphviz,+    optparse-applicative    default-language:    Haskell2010 @@ -88,7 +90,8 @@     fgl,     mtl,     dlist,-    graphviz+    graphviz,+    optparse-applicative      -- Directories containing source files.   -- hs-source-dirs: