monadloc-pp (empty) → 0.1

raw patch · 3 files changed

+132/−0 lines, 3 filesdep +basedep +filepathdep +haskell-src-extssetup-changed

Dependencies added: base, filepath, haskell-src-exts, monadloc, pretty, syb

Files

• MonadLoc.hs +100/−0
• Setup.hs +2/−0
• monadloc-pp.cabal +30/−0

@@ -0,0 +1,100 @@+{-# LANGUAGE PatternGuards #-}++import Data.Generics+import Data.List+import Language.Haskell.Exts.Annotated+import System.Environment+import System.FilePath+import Text.PrettyPrint++main :: IO ()+main = do+  args <- getArgs+  case args of++    (fn:inp:outp:_) -> do+         contents <- readFile inp+         let res = work fn contents+         writeFile outp res++    [] -> do+         contents <- getContents+         putStrLn $ work "INPUT" contents++    _ -> error "USAGE: MonadLoc expects the input from stdin and writes to stdout"++work :: FilePath -> String -> String+work fn contents =+         -- Invent a fake name for lhs files to avoid confusing haskell-src-exts+         let fn' = if takeExtension fn == ".lhs" then dropExtension fn <.> "hs" else fn++             Module l mhead opt imports decls =+               fromParseResult $+               parseFileContentsWithMode ourParseMode{parseFilename = fn'} contents+             mod'   = Module l mhead opt imports decls'+             mname  = case mhead of+                        Nothing -> ""+                        Just (ModuleHead _ mn _ _) -> prettyPrint mn+             decls' = map (annotateDecl mname) decls+         in prettyPrintStyleMode style{lineLength=100000} ourPrintMode mod'++ourParseMode :: ParseMode+ourParseMode = defaultParseMode { ignoreLinePragmas = False,+                                  extensions =+                                        [CPP+                                        ,MultiParamTypeClasses+                                        ,FunctionalDependencies+                                        ,FlexibleContexts+                                        ,FlexibleInstances+                                        ,ExplicitForall+                                        ,ExistentialQuantification+                                        ,PatternGuards+                                        ,ViewPatterns+                                        ,Arrows+                                        ,NamedFieldPuns+                                        ,DisambiguateRecordFields+                                        ,RecordWildCards+                                        ,StandaloneDeriving+                                        ,GeneralizedNewtypeDeriving+                                        ,ScopedTypeVariables+                                        ,PatternSignatures+                                        ,PackageImports+                                        ,QuasiQuotes+                                        ,PostfixOperators]+                                }++ourPrintMode :: PPHsMode+ourPrintMode = defaultMode { linePragmas = True }+++annotateDecl :: String -> Decl SrcSpanInfo -> Decl SrcSpanInfo+annotateDecl mname e@(FunBind _ (m:_)) = everywhere (mkT (annotateStatements (Just funName) mname)) e+  where+    funName = case m of+              Match _ name _ _ _ -> prettyPrint name+              InfixMatch _ _ name _ _ _ -> prettyPrint name++annotateDecl mname e@(PatBind _ (PVar _ fn) _ _ _) = everywhere (mkT (annotateStatements (Just $ prettyPrint fn) mname)) e+annotateDecl mname e = everywhere (mkT (annotateStatements Nothing mname)) e++annotateStatements :: Maybe String -> String -> Exp SrcSpanInfo -> Exp SrcSpanInfo+annotateStatements fun m (Do loc stmts)  = App loc (withLocCall fun m loc) (Paren loc $ Do  loc $ map (annotateStmt fun m) stmts)+annotateStatements fun m (MDo loc stmts) = App loc (withLocCall fun m loc) (Paren loc $ MDo loc $ map (annotateStmt fun m) stmts)+annotateStatements _   _ e = e++annotateStmt :: Maybe String ->  String -> Stmt SrcSpanInfo -> Stmt SrcSpanInfo+annotateStmt fun m (Generator loc pat exp) = Generator loc pat $ App loc (withLocCall fun m loc) (Paren loc exp)+annotateStmt fun m (Qualifier loc exp)     = Qualifier loc $ App loc (withLocCall fun m loc) (Paren loc exp)+annotateStmt fun m (RecStmt loc stmts)     = RecStmt loc $ map (annotateStmt fun m) stmts+annotateStmt _   _ stmt                    = stmt++withLocCall :: Maybe String -> String -> SrcSpanInfo -> Exp SrcSpanInfo+withLocCall fun m loc = App loc (Var loc withLoc) (Lit loc srclocLit)+  where+   withLoc   = Qual loc (ModuleName loc "Control.Monad.Loc") (Ident loc "withLoc")+   srclocLit = String loc (render locString) ""+   locStringTail = text m <> parens(text (fileName loc)) <> colon <+> parens (int (startLine loc) <> comma <+> int(startColumn loc))+   locString = case fun of+                 Nothing  -> locStringTail+                 Just fun -> text fun <> comma <+> locStringTail+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,30 @@+name: monadloc-pp+version: 0.1+Cabal-Version:  >= 1.6+build-type: Simple+license: PublicDomain+author: Pepe Iborra+maintainer: pepeiborra@gmail.com+homepage: http://github.com/pepeiborra/monadloc+synopsis: A preprocessor for generating monadic call traces+category: Control, Monads+stability: experimental+description:+  The package @monadloc@ defines a class for monads which can keep a monadic call trace.+  .+  * See the blog post <http://pepeiborra.posterous.com/monadic-stack-traces-that-make-a-lot-of-sense> for more information.+  .+  This package provides a preprocessor that inserts calls+  to "Control.Monad.Loc.withLoc" before every monadic statement in a module.+  To invoke the preprocessor, add the pragma @OPTIONS_GHC -F -pgmF MonadLoc@  at the top of your Haskell files  together with an import for the "Control.Monad.Loc" module+  .++Executable MonadLoc+   buildable: True+   build-depends: base >= 4 && < 5, pretty, syb, monadloc == 0.6, haskell-src-exts >= 1.3.0, filepath+   main-is: MonadLoc.hs+   ghc-options: -Wall -fno-warn-name-shadowing++source-repository head+  type:     git+  location: git://github.com/pepeiborra/monadloc-pp.git