monadloc (empty) → 0.1
raw patch · 4 files changed
+185/−0 lines, 4 filesdep +basedep +haskell-src-extsdep +prettysetup-changed
Dependencies added: base, haskell-src-exts, pretty, syb, template-haskell
Files
- Control/Monad/Loc.hs +56/−0
- MonadLoc.hs +77/−0
- Setup.hs +2/−0
- monadloc.cabal +50/−0
+ Control/Monad/Loc.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE FlexibleInstances #-}++{-|+ This package defines a MonadLoc class for monads which support Monadic Call Traces.+ See http://pepeiborra.posterous.com/monadic-stack-traces-that-make-a-lot-of-sense++ * Traces are only provided for explicitly annotated program points.++ * This package installs the MonadLoc preprocessor for this purpose.+ To enable it include the following pragma at the top of your haskell source files:++ > {-# OPTIONS_GHC -F -pgmF MonadLoc #-}++ * There is also the TH macro 'withLocTH' to manually annotate program points,+ but you should always use the preprocessor if possible.+-}+module Control.Monad.Loc (MonadLoc(..), withLocTH) where+import Language.Haskell.TH.Syntax (qLocation, Loc(..), Q, Exp)+import Text.PrettyPrint+import Prelude hiding (mod)++-- | Generating stack traces for failures+class Monad m => MonadLoc m where+ -- | 'withLoc' records the given source location in the failure trace+ -- if the underlying monad supports recording location traces+ --+ withLoc :: String -> m a -> m a+++instance Monad m => MonadLoc m where withLoc _ = id;+++-- | 'withLocTH' is a convenient TH macro which expands to 'withLoc' @\<source location\>@+-- It should only be used when the MonadLoc preprocessor is not available.+-- Usage:+--+-- > f x = $withLocTH $ do+-- > $withLocTH $ something+-- > x < -$withLocTH $ something-else+-- > ...+--+-- NOTE: unfortunately type signatures are necessary when using withLocTH++withLocTH :: Q Exp+withLocTH = do+ loc <- qLocation+ let loc_msg = showLoc loc+ [| withLoc loc_msg |]++showLoc :: Loc -> String+showLoc Loc{loc_module=mod, loc_filename=filename, loc_start=start} = render $+ {- text package <> char '.' <> -}+ text mod <> parens (text filename) <> colon <+> text (show start)
+ MonadLoc.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE PatternGuards #-}++import Control.Applicative+import Data.Generics+import Language.Haskell.Exts.Annotated+import System.Environment+import Text.PrettyPrint++main :: IO ()+main = do+ (fn:inp:outp:_) <- getArgs+ Module l mhead opt imports decls <- fromParseResult <$>+ parseFileWithMode ourParseMode{parseFilename = fn} inp+ let mod' = Module l mhead opt imports decls'+ mname = case mhead of+ Nothing -> ""+ Just (ModuleHead _ mn _ _) -> prettyPrint mn+ decls' = map (annotateDecl mname) decls+ writeFile outp $ prettyPrintStyleMode style{lineLength=100000} ourPrintMode mod'++ourParseMode :: ParseMode+ourParseMode = defaultParseMode { 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 loc (m:_)) = everywhere (mkT (annotateStatements (Just funName) mname)) e+ where+ funName | Match _ name _ _ _ <- m = prettyPrint name+ | InfixMatch _ _ name _ _ _ <- m = 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+ | Nothing <- fun = locStringTail+ | Just fun <- fun = text fun <> comma <+> locStringTail+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monadloc.cabal view
@@ -0,0 +1,50 @@+name: monadloc+version: 0.1+Cabal-Version: >= 1.2.3+build-type: Simple+license: PublicDomain+author: Pepe Iborra+maintainer: pepeiborra@gmail.com+homepage: http://github.com/pepeiborra/monadloc+synopsis: A class for monads which can keep a stack trace+category: Control, Monads+stability: experimental+description:+ This package defines a class for monads which can keep a monadic call trace.+ .+ . See http://pepeiborra.posterous.com/monadic-stack-traces-that-make-a-lot-of-sense for more information.+ .+ A preprocessor is provided which can insert calls+ to withLoc before every monadic statement in a module.+ .+ To invoke the preprocessor, add the following pragma at the top of a source file:+ .+ > {-# OPTIONS_GHC -F -pgmF MonadLoc #-}+ .+ together with an import for the @Control.Monad.Loc@ module+ .+ This package provides no implementation of the MonadLoc interface.+ Currently the only package that does so is "control-monad-exception",+ but any other package can implement it and provide monadic call traces.++Flag syb-in-base+ default: False++Library+ buildable: True+ build-depends: pretty, template-haskell++ if flag(syb-in-base)+ build-depends: base >= 3 && < 4+ else+ build-depends: base >= 4 && < 5, syb+ ghc-options: -Wall+ extensions: FlexibleInstances, OverlappingInstances, UndecidableInstances, TemplateHaskell, PatternGuards+ exposed-modules:+ Control.Monad.Loc++Executable MonadLoc+ buildable: True+ build-depends: haskell-src-exts+ main-is: MonadLoc.hs+ ghc-options: -Wall -fno-warn-name-shadowing