diff --git a/Control/Monad/Loc.hs b/Control/Monad/Loc.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Loc.hs @@ -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' @\@ +-- 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) diff --git a/MonadLoc.hs b/MonadLoc.hs new file mode 100644 --- /dev/null +++ b/MonadLoc.hs @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/monadloc.cabal b/monadloc.cabal new file mode 100644 --- /dev/null +++ b/monadloc.cabal @@ -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