diff --git a/Control/Monad/Loc.hs b/Control/Monad/Loc.hs --- a/Control/Monad/Loc.hs +++ b/Control/Monad/Loc.hs @@ -21,8 +21,8 @@ -} module Control.Monad.Loc (MonadLoc(..), withLocTH) where import Language.Haskell.TH.Syntax (qLocation, Loc(..), Q, Exp) -import Text.PrettyPrint import Prelude hiding (mod) +import Text.Printf -- | Generating stack traces for failures class Monad m => MonadLoc m where @@ -52,6 +52,6 @@ [| withLoc loc_msg |] showLoc :: Loc -> String -showLoc Loc{loc_module=mod, loc_filename=filename, loc_start=start} = render $ +showLoc Loc{loc_module=mod, loc_filename=filename, loc_start=start} = {- text package <> char '.' <> -} - text mod <> parens (text filename) <> colon <+> text (show start) + printf "%s (%s). %s" mod filename (show start) diff --git a/Control/Monad/Loc/MTL.hs b/Control/Monad/Loc/MTL.hs deleted file mode 100644 --- a/Control/Monad/Loc/MTL.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverlappingInstances #-} -module Control.Monad.Loc.MTL where - -import Control.Monad.Loc - -import Control.Monad.Error -import Control.Monad.List -import Control.Monad.Reader -import Control.Monad.State.Lazy as Lazy -import Control.Monad.State.Strict as Strict -import Control.Monad.Writer.Lazy as Lazy -import Control.Monad.Writer.Strict as Strict -import Control.Monad.RWS.Lazy as Lazy -import Control.Monad.RWS.Strict as Strict -import Data.Monoid - -instance MonadLoc m => MonadLoc (ListT m) where - withLoc l = ListT . withLoc l . runListT - -instance (Error e, MonadLoc m) => MonadLoc (ErrorT e m) where - withLoc l = ErrorT . withLoc l . runErrorT - -instance MonadLoc m => MonadLoc (ReaderT r m) where - withLoc l m = ReaderT $ \r -> withLoc l $ runReaderT m r - -instance (Monoid w, MonadLoc m) => MonadLoc (Lazy.WriterT w m) where - withLoc l = Lazy.WriterT . withLoc l . Lazy.runWriterT - -instance MonadLoc m => MonadLoc (Lazy.StateT s m) where - withLoc l m = Lazy.StateT $ \s -> withLoc l $ Lazy.runStateT m s - -instance (Monoid w, MonadLoc m) => MonadLoc (Lazy.RWST r w s m) where - withLoc l m = Lazy.RWST $ \r s -> withLoc l $ Lazy.runRWST m r s - -instance (Monoid w, MonadLoc m) => MonadLoc (Strict.WriterT w m) where - withLoc l = Strict.WriterT . withLoc l . Strict.runWriterT - -instance MonadLoc m => MonadLoc (Strict.StateT s m) where - withLoc l m = Strict.StateT $ \s -> withLoc l $ Strict.runStateT m s - -instance (Monoid w, MonadLoc m) => MonadLoc (Strict.RWST r w s m) where - withLoc l m = Strict.RWST $ \r s -> withLoc l $ Strict.runRWST m r s diff --git a/Control/Monad/Loc/Transformers.hs b/Control/Monad/Loc/Transformers.hs --- a/Control/Monad/Loc/Transformers.hs +++ b/Control/Monad/Loc/Transformers.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE OverlappingInstances #-} + +{-| + This package contains MonadLoc instance declarations for the monad + transformer type constructors in the @transformers@ package. +-} + module Control.Monad.Loc.Transformers where import Control.Monad.Loc diff --git a/MonadLoc.hs b/MonadLoc.hs deleted file mode 100644 --- a/MonadLoc.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -import Control.Applicative -import Data.Generics -import Language.Haskell.Exts.Annotated -import System.Environment -import Text.PrettyPrint - -main :: IO () -main = do - args <- getArgs - case args of - - (fn:inp:outp:_) -> do - 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' --- writeFile outp $ exactPrint mod' [] - - [] -> do - contents <- getContents - let Module l mhead opt imports decls = - fromParseResult $ - parseFileContentsWithMode ourParseMode contents - let mod' = Module l mhead opt imports decls' - mname = case mhead of - Nothing -> "" - Just (ModuleHead _ mn _ _) -> prettyPrint mn - decls' = map (annotateDecl mname) decls - - putStrLn $ prettyPrintStyleMode style{lineLength=100000} ourPrintMode mod' - - _ -> error "USAGE: MonadLoc expects the input from stdin and writes to stdout" - - -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 _ (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 - diff --git a/monadloc.cabal b/monadloc.cabal --- a/monadloc.cabal +++ b/monadloc.cabal @@ -1,5 +1,5 @@ name: monadloc -version: 0.5 +version: 0.6 Cabal-Version: >= 1.6 build-type: Simple license: PublicDomain @@ -14,7 +14,7 @@ . * See the blog post for more information. . - A preprocessor is provided which can insert calls + A preprocessor is available (see the package monadloc-pp) which 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 . @@ -22,45 +22,19 @@ 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 - -Flag mtl - default: True - -Flag transformers - default: True + /Changes/: + . + * 0.6 - Extracted the preprocessor to a separate package @monadloc-pp@ to minimize the set of dependencies. 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 - - if flag(mtl) - cpp-options: -DMTL - build-depends: mtl - exposed-modules: Control.Monad.Loc.MTL - - if flag(transformers) - cpp-options: -DTRANSFORMERS - build-depends: transformers - exposed-modules: Control.Monad.Loc.Transformers + build-depends: base >= 4 && < 5, template-haskell, transformers ghc-options: -Wall -fno-warn-orphans extensions: FlexibleInstances, OverlappingInstances, UndecidableInstances, TemplateHaskell, PatternGuards exposed-modules: Control.Monad.Loc - -Executable MonadLoc - buildable: True - build-depends: haskell-src-exts >= 1.3.0 - main-is: MonadLoc.hs - ghc-options: -Wall -fno-warn-name-shadowing - + Control.Monad.Loc.Transformers source-repository head type: git