visual-prof (empty) → 0.1
raw patch · 7 files changed
+2228/−0 lines, 7 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, haskell-src-exts, mtl, parsec, pretty, process, regexpr, uniplate
Files
- GraphUtils.hs +86/−0
- LICENSE +27/−0
- ParseProfile.hs +414/−0
- Pretty.hs +1510/−0
- Prof2Html.hs +149/−0
- Setup.lhs +4/−0
- visual-prof.cabal +38/−0
+ GraphUtils.hs view
@@ -0,0 +1,86 @@+--+-- GraphUtils.hs+--+-- Copyright (c) 2007, 2008 Antiope Associates LLC, all rights reserved.+--++module GraphUtils (+ collapseParallel,+ prune,+ totalCost+) where++import Data.IntMap as IntMap+import Data.List as List++import ParseProfile+++-- For a list of calls, compute the sum of the counts (number of+-- calls), ticks and allocs+--+totalCost :: [ CallInfo ] -> (Integer, Integer, Integer)+totalCost cis = let+ cis' = nubBy (\x y -> stackNumber x == stackNumber y) cis+ in+ foldl (\(c, t, a) ci -> (c + counts ci, t + ticks ci, a + allocs ci)) (0, 0, 0) cis'+++collapseCost :: [ CallInfo ] -> CallInfo+collapseCost = foldl (\ci ci' -> ci { parentNodeNumber = parentNodeNumber ci',+ stackNumber = stackNumber ci',+ counts = counts ci + counts ci',+ ticks = ticks ci + ticks ci',+ allocs = allocs ci + allocs ci'} ) emptyCallInfo+ where+ emptyCallInfo = CallInfo { parentNodeNumber = undefined,+ stackNumber = undefined,+ counts = 0,+ ticks = 0,+ allocs = 0 }++prunable :: Node -> Bool+prunable n = isLeaf n && totalCost (parentNodes n) == (0, 0, 0)+++-- The first thing to do is to find all the leaf nodes and delete+-- the ones that have no costs associated with them. The pruneOnce+-- function deletes the zero cost leaf nodes and returns a pair+-- of the number of changes made and the pruned profile graph.+--+pruneOnce :: ProfileGraph -> (Int, ProfileGraph)+pruneOnce g = let+ pruneNode :: (Int, ProfileGraph) -> Int -> (Int, ProfileGraph)+ pruneNode (i, g') nc = if prunable (g' ! nc)+ then (i + 1, IntMap.delete nc g')+ else (i, g')+ (nChanges, g'') = foldl pruneNode (0, g) (keys g)+ in+ (nChanges, markParents g'')++-- repeatedly prune until there are no more changes+--+prune :: ProfileGraph -> ProfileGraph+prune g = let+ (nChanges, g') = pruneOnce g+ in+ if nChanges == 0 then g' else prune g'+++-- Collapse parallel edges to a single edge+--+collapseParallel :: ProfileGraph -> ProfileGraph+collapseParallel = IntMap.map collapseParents+++-- For a given node n, collapse all of the parents with the same+-- parentNode number.+--+collapseParents :: Node -> Node+collapseParents n = let+ ps = parentNodes n+ ps' = group (sort ps)+ ci = List.map collapseCost ps'+ in+ n { parentNodes = ci }+
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2007, 2008 Antiope Associates LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY ANTIOPE ASSOCIATES AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ ParseProfile.hs view
@@ -0,0 +1,414 @@+--+-- ParseProfile.hs+--+-- Copyright (c) 2008 Antiope Associates LLC, all rights reserved.+--+--+-- This module parses the profile file generated when a program is run+-- with the +RTS -px -RTS flag. The result is a Profile record that+-- contains all of the information from the file.+--+-- Although it does not describe the exact format output when using the+-- +RTS -px -RTS flag, the best reference on the cost center stack accounting+-- scheme is+--+-- Morgan, R.G. and S.A. Jarvis, "Profiling large-scale lazy+-- functional programs", J. Functional Prog 8 (3), 1998,+-- pp. 201 - 237.+-- +-- The format of the profile file generated when using the "-px" flag:+--+-- The first line is a quoted string giving the time of day when the+-- profile was generated:+--+-- <timestamp>+--+-- The second line is a quoted string giving the sampling interval, e.g.,+-- "20 ms":+--+-- <tick interval>+--+-- The profiling data begins with lines listing the names of all the cost+-- centers, and the module to which each belongs. Each line begins with+-- a literal '1':+--+-- 1 <cost center number> <cost center name> <module name>+--+-- The <cost center number> is a integer, the <cost center name> and+-- <module name> are quoted strings.+--+-- The call tree itself is given by lines beginning with a literal '2'.+-- Each line looks like:+--+-- 2 <cost center stack code> <root code> <cost center number> <parent node>+--+-- The <cost center stack code> is identifies the stack to which this+-- <cost center number> belongs. The <root code> is a literal '1' if this+-- cost center is the root of the call tree, a literal '2' otherwise.+-- The <parent node> is the cost center stack code of the parent of this+-- cost center. If the <root code> is '1' the <parent node> field is+-- absent. The <cost center stack code>, <cost center number> and+-- <parent node> are all integers.+--+-- One important thing to note is that multiple lines can have the same+-- <cost center stack code>. Only the first entry contains cost accounting+-- data. The other lines with the same <cost center stack code> are "back edges",+-- used internally by the run time system to efficiently navigate the+-- cost center stack graph, but not containing any additional accounting+-- information.+--+-- The final line of the file contains all of the actual profiling data.+-- The format is:+--+-- 5 <total ticks> {1 <cost center stack code> <call count> <tick count> <alloc count>}+ 0+--+-- where the expression in curly braces is repeated for all of the+-- cost center stack codes. Each cost reports for <cost center stack code>+-- begins with a literal '1'. The <cost center stack code> and the+-- <call count>, <tick count> and <alloc count> are all integers. The end+-- of the profiling data is indicated by a literal '0'.+--+-- So what's a cost center and what is a cost center stack? A cost center+-- is simply a section of code to which costs are attributed. It is+-- often a function, but source code annotations can be used to divide+-- a function into several cost centers.+--+-- For the purpose of understanding the profiling file format, a cost+-- center stack is just a cost center and its calling cost center.+-- Costs --- call counts, ticks spent executing and allocations --- are+-- sttributed to call center stacks. This means, for example, that if+-- both function_1 and function_2 call map, the costs of map will be+-- in two call center stacks, one with function_1 as the parent of+-- map, and another with function_2 as its parent. In essence, a+-- call center stack can be thought of as an _edge_ of the call graph,+-- while the cost centers themselves are the nodes.+--+-- Note that the <cost center stack code> may not be unique. This can+-- happen, for instance, if there are mutually recursive cost centers.+-- In that case costs, while attributable to a particular node (cost center)+-- can't be attributed to a specific edge (cost center stack).+--+-- Parsing the profile returns a data structure called a ProfileGraph.+-- This is an IntMap keyed by <cost center number>. The entries in the+-- map are records giving the name of the cost center and the module to+-- which it belongs, and an incidence list giving the nodes that call+-- this cost center and the costs associated with each.+--+-- Note that the conversion from call tree (in which each cost center+-- can appear multiple times) to call graph (where each cost center+-- appears only once) is implicitly done as part of the generation of+-- the ProfileGraph record.+--++module ParseProfile (+ CallInfo(..),+ Node(..),+ Profile(..),+ ProfileGraph,+ markParents,+ parseProfile+) where+++import Control.Exception+import Data.IntMap as IntMap+import Data.List as List+import Data.Maybe as Maybe+import Text.ParserCombinators.Parsec as Parsec+++-- The CostCenter, CostCenterStack and CostCenterReport records+-- hold the raw results of parsing the profile.+--+data CostCenter =+ CostCenter { ccName :: String,+ ccModule :: String }+ deriving (Show)++data CostCenterStack =+ CostCenterStack { childNode :: Int,+ parentStack :: Maybe Int }+ deriving (Show)++data CostCenterReport =+ CostCenterReport { reportCount :: Integer,+ reportTicks :: Integer,+ reportAlloc :: Integer }+ deriving (Show)+++defaultCostCenterReport :: CostCenterReport+defaultCostCenterReport =+ CostCenterReport { reportCount = 0,+ reportTicks = 0,+ reportAlloc = 0 }+++-- The Profile, ProfileGraph, Node and CallingNode types are+-- used to return the annotated call graph.+--+type EdgeCode = Int+type NodeCode = Int+type ProfileGraph = IntMap Node++data Node =+ Node { nodeNumber :: Int,+ nodeName :: String,+ nodeModule :: String,+ isLeaf :: Bool,+ parentNodes :: [ CallInfo ] }+ deriving (Show)++data CallInfo =+ CallInfo { parentNodeNumber :: Int,+ stackNumber :: Int,+ counts :: Integer,+ ticks :: Integer,+ allocs :: Integer }+ deriving (Show)+++data Profile =+ Profile { timestamp :: String,+ tickInterval :: String,+ profileTicks :: Integer,+ profileGraph :: ProfileGraph }+ deriving (Show)+++-- Instances of Eq and Ord for CallInfo are handy for grouping+-- and sorting the parent nodes.+-- +instance Eq CallInfo where+ (==) c1 c2 | pn1 == pn2 = True+ | otherwise = False+ where+ pn1 = parentNodeNumber c1+ pn2 = parentNodeNumber c2+++instance Ord CallInfo where+ compare c1 c2 | pn1 == pn2 = EQ+ | pn1 < pn2 = LT+ | otherwise = GT+ where+ pn1 = parentNodeNumber c1+ pn2 = parentNodeNumber c2+++-- The parser+--+costCenterCode :: Parser Char+costCenterCode = char '1'++costCenterStackCode :: Parser Char+costCenterStackCode = char '2'++timeUpdateCode :: Parser Char+timeUpdateCode = char '5'++eol :: Parser ()+eol = do+ Parsec.try (do char '\r'; newline) <|> newline+ return ()+ <?> "eol"++natural :: Parser Int+natural = do+ digits <- many1 digit+ return ((read digits) :: Int)+ <?> "natural"++naturalLong :: Parser Integer+naturalLong = do+ digits <- many1 digit+ return ((read digits) :: Integer)+ <?> "naturalLong"++quotedString :: Parser String+quotedString = do+ char '"'+ manyTill anyChar (Parsec.try (char '"'))+ <?> "quotedString"++headerStr :: Parser String+headerStr = do + header <- quotedString; eol+ return header+ <?> "headerString"++costCenter :: Parser (NodeCode, CostCenter)+costCenter = do+ costCenterCode; space+ ccId <- natural; space+ name <- quotedString; space+ modul <- quotedString; eol+ return (ccId, CostCenter { ccName = name,+ ccModule = modul })+ <?> "costCenter"++costCenterStack :: Parser (EdgeCode, [ CostCenterStack ])+costCenterStack = do+ costCenterStackCode; space+ ccsId <- natural; space+ stackCode <- oneOf "12"; space+ node <- natural+ parent <- do if stackCode == '1'+ then return Nothing+ else do+ space+ p <- natural+ return (Just p)+ eol+ return (ccsId, [ CostCenterStack { childNode = node,+ parentStack = parent } ] )+ <?> "costCenterStack"+++ccsReport :: Parser (EdgeCode, CostCenterReport)+ccsReport = do+ char '1'; space+ ccsId <- natural; space+ cs <- naturalLong; space+ ts <- naturalLong; space+ as <- naturalLong; space+ return (ccsId, CostCenterReport { reportCount = cs,+ reportTicks = ts,+ reportAlloc = as })+ <?> "ccsReport"+++totalTicks :: Parser Integer+totalTicks = do+ timeUpdateCode; space+ ts <- naturalLong; space+ return ts+ <?> "totalTicks"+++profile :: Parser Profile+profile = do+ stamp <- headerStr+ step <- headerStr+ costCenters <- many costCenter+ costCenterStacks <- many costCenterStack+ totalTime <- totalTicks+ times <- manyTill ccsReport (Parsec.try (char '0'))+ let+ p = mkProfileGraph costCenters costCenterStacks times++ return Profile { timestamp = stamp,+ tickInterval = step,+ profileTicks = totalTime,+ profileGraph = p }+ <?> "profile"+++-- Helper functions for converting the CostCenter, CostCenterStack+-- and CostCenterReport lists into a ProfileGraph.+--+allSame :: Eq a => [ a ] -> Bool+allSame [] = True+allSame (_ : []) = True+allSame (x : xs) = if x /= head xs then False else allSame xs++ +mkEdge :: IntMap [ CostCenterStack ]+ -> IntMap CostCenterReport+ -> EdgeCode+ -> (NodeCode, [ CallInfo ])+mkEdge edgeMap costMap e = let+ sts = edgeMap ! e+ children = List.map childNode sts+ child = assert (allSame children) (head children)++ getCallInfo :: CostCenterStack -> Maybe CallInfo+ getCallInfo st = let+ parent = if isJust (parentStack st)+ then let offspring = List.map childNode (edgeMap ! (fromJust (parentStack st)))+ in assert (allSame children) (Just (head offspring))+ else Nothing+ in+ if isJust parent+ then let+ c = findWithDefault defaultCostCenterReport e costMap+ in+ Just CallInfo { parentNodeNumber = fromJust parent,+ stackNumber = e,+ counts = reportCount c,+ ticks = reportTicks c,+ allocs = reportAlloc c }+ else Nothing+ in+ (child, Maybe.mapMaybe getCallInfo sts)+++mkEdges :: [ (EdgeCode, [ CostCenterStack ]) ]+ -> [ (EdgeCode, CostCenterReport) ]+ -> [ (NodeCode, [ CallInfo ]) ]+mkEdges ccss costs = let+ edgeMap = fromListWith (\_ x -> x) ccss+ costMap = fromList costs+ mkEdge' = mkEdge edgeMap costMap+ in+ List.map mkEdge' (keys edgeMap)+++edgesToNodes :: [ (NodeCode, CostCenter) ]+ -> [ (NodeCode, [ CallInfo ]) ]+ -> [ (NodeCode, Node) ] +edgesToNodes nodes edges = let+ nodeMap = fromList nodes+ mkNode :: (NodeCode, [ CallInfo ]) -> (NodeCode, Node)+ mkNode (n, ci) = (n, Node { nodeNumber = n,+ nodeName = ccName (nodeMap ! n),+ nodeModule = ccModule (nodeMap ! n),+ isLeaf = True,+ parentNodes = ci } )+ in+ List.map mkNode edges+++concatParents :: Node -> Node -> Node+concatParents n n' = Node { nodeNumber = nodeNumber n,+ nodeName = nodeName n,+ nodeModule = nodeModule n,+ isLeaf = (isLeaf n) && (isLeaf n'),+ parentNodes = (parentNodes n) ++ (parentNodes n') }+++-- Mark the Leaf nodes+--+markAll :: ProfileGraph -> ProfileGraph+markAll g = IntMap.map (\n -> n { isLeaf = True }) g++markParents :: ProfileGraph -> ProfileGraph+markParents g = let+ nonLeaf = concatMap (\n -> List.map parentNodeNumber (parentNodes (g ! n))) (keys g)+ g' = markAll g++ markAsParent :: ProfileGraph -> NodeCode -> ProfileGraph+ markAsParent gr n = update (\n' -> Just n' { isLeaf = False }) n gr+ in+ foldl markAsParent g' nonLeaf+++-- Convert the raw CostCenter, CostCenterStack and CostCenterReport+-- lists into a ProfileGraph.+--+mkProfileGraph :: [ (NodeCode, CostCenter) ]+ -> [ (EdgeCode, [ CostCenterStack ] ) ]+ -> [ (EdgeCode, CostCenterReport) ]+ -> ProfileGraph+mkProfileGraph ccs ccss costs = let+ edges = mkEdges ccss costs -- [ (NodeCode, [ CallInfo ]) ]+ nodes = edgesToNodes ccs edges -- [ (NodeCode, Node) ]+ in+ markParents $ fromListWith concatParents nodes++ +parseProfile :: FilePath -> String -> Maybe Profile+parseProfile name input =+ case parse profile name input of+ Left _ -> Nothing+ Right prof -> Just prof
+ Pretty.hs view
@@ -0,0 +1,1510 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.Exts.Pretty+-- Copyright : (c) Niklas Broberg 2004-2009,+-- (c) The GHC Team, Noel Winstanley 1997-2000+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, d00nibro@chalmers.se+-- Stability : stable+-- Portability : portable+--+-- Pretty printer for Haskell with extensions.+--+-----------------------------------------------------------------------------++module Pretty (+ -- * Pretty printing+ Pretty,+ prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,+ -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")+ P.Style(..), P.style, P.Mode(..),+ -- * Haskell formatting modes+ PPHsMode(..), Indent, PPLayout(..), defaultMode) where++import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Annotated.Syntax as A+import Language.Haskell.Exts.Annotated.Simplify++import Language.Haskell.Exts.SrcLoc++import qualified Text.PrettyPrint as P+import Data.List (intersperse)++infixl 5 $$$++-----------------------------------------------------------------------------++-- | Varieties of layout we can use.+data PPLayout = PPOffsideRule -- ^ classical layout+ | PPSemiColon -- ^ classical layout made explicit+ | PPInLine -- ^ inline decls, with newlines between them+ | PPNoLayout -- ^ everything on a single line+ deriving Eq++type Indent = Int++-- | Pretty-printing parameters.+--+-- /Note:/ the 'onsideIndent' must be positive and less than all other indents.+data PPHsMode = PPHsMode {+ -- | indentation of a class or instance+ classIndent :: Indent,+ -- | indentation of a @do@-expression+ doIndent :: Indent,+ -- | indentation of the body of a+ -- @case@ expression+ caseIndent :: Indent,+ -- | indentation of the declarations in a+ -- @let@ expression+ letIndent :: Indent,+ -- | indentation of the declarations in a+ -- @where@ clause+ whereIndent :: Indent,+ -- | indentation added for continuation+ -- lines that would otherwise be offside+ onsideIndent :: Indent,+ -- | blank lines between statements?+ spacing :: Bool,+ -- | Pretty-printing style to use+ layout :: PPLayout,+ -- | add GHC-style @LINE@ pragmas to output?+ linePragmas :: Bool+ }++-- | The default mode: pretty-print using the offside rule and sensible+-- defaults.+defaultMode :: PPHsMode+defaultMode = PPHsMode{+ classIndent = 8,+ doIndent = 3,+ caseIndent = 4,+ letIndent = 4,+ whereIndent = 6,+ onsideIndent = 2,+ spacing = True,+ layout = PPOffsideRule,+ linePragmas = False+ }++-- | Pretty printing monad+newtype DocM s a = DocM (s -> a)++instance Functor (DocM s) where+ fmap f xs = do x <- xs; return (f x)++instance Monad (DocM s) where+ (>>=) = thenDocM+ (>>) = then_DocM+ return = retDocM++{-# INLINE thenDocM #-}+{-# INLINE then_DocM #-}+{-# INLINE retDocM #-}+{-# INLINE unDocM #-}+{-# INLINE getPPEnv #-}++thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b+thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)++then_DocM :: DocM s a -> DocM s b -> DocM s b+then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s)++retDocM :: a -> DocM s a+retDocM a = DocM (\_s -> a)++unDocM :: DocM s a -> (s -> a)+unDocM (DocM f) = f++-- all this extra stuff, just for this one function.+getPPEnv :: DocM s s+getPPEnv = DocM id++-- So that pp code still looks the same+-- this means we lose some generality though++-- | The document type produced by these pretty printers uses a 'PPHsMode'+-- environment.+type Doc = DocM PPHsMode P.Doc++-- | Things that can be pretty-printed, including all the syntactic objects+-- in "Language.Haskell.Exts.Syntax" and "Language.Haskell.Exts.Annotated.Syntax".+class Pretty a where+ -- | Pretty-print something in isolation.+ pretty :: a -> Doc+ -- | Pretty-print something in a precedence context.+ prettyPrec :: Int -> a -> Doc+ pretty = prettyPrec 0+ prettyPrec _ = pretty++-- The pretty printing combinators++empty :: Doc+empty = return P.empty++nest :: Int -> Doc -> Doc+nest i m = m >>= return . P.nest i+++-- Literals++text, ptext :: String -> Doc+text = return . P.text+ptext = return . P.text++zeroWidthText = return . P.zeroWidthText++char :: Char -> Doc+char = return . P.char++int :: Int -> Doc+int = return . P.int++integer :: Integer -> Doc+integer = return . P.integer++float :: Float -> Doc+float = return . P.float++double :: Double -> Doc+double = return . P.double++rational :: Rational -> Doc+rational = return . P.rational++-- Simple Combining Forms++parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc+parens d = d >>= return . P.parens+brackets d = d >>= return . P.brackets+braces d = d >>= return . P.braces+quotes d = d >>= return . P.quotes+doubleQuotes d = d >>= return . P.doubleQuotes++parensIf :: Bool -> Doc -> Doc+parensIf True = parens+parensIf False = id++-- Constants++semi,comma,colon,space,equals :: Doc+semi = return P.semi+comma = return P.comma+colon = return P.colon+space = return P.space+equals = return P.equals++lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc+lparen = return P.lparen+rparen = return P.rparen+lbrack = return P.lbrack+rbrack = return P.rbrack+lbrace = return P.lbrace+rbrace = return P.rbrace++-- Combinators++(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc+aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}+aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}+aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}+aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}++hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc+hcat dl = sequence dl >>= return . P.hcat+hsep dl = sequence dl >>= return . P.hsep+vcat dl = sequence dl >>= return . P.vcat+sep dl = sequence dl >>= return . P.sep+cat dl = sequence dl >>= return . P.cat+fsep dl = sequence dl >>= return . P.fsep+fcat dl = sequence dl >>= return . P.fcat++-- Some More++hang :: Doc -> Int -> Doc -> Doc+hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}++-- Yuk, had to cut-n-paste this one from Pretty.hs+punctuate :: Doc -> [Doc] -> [Doc]+punctuate _ [] = []+punctuate p (d1:ds) = go d1 ds+ where+ go d [] = [d]+ go d (e:es) = (d <> p) : go e es++-- | render the document with a given style and mode.+renderStyleMode :: P.Style -> PPHsMode -> Doc -> String+renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode++-- | render the document with a given mode.+renderWithMode :: PPHsMode -> Doc -> String+renderWithMode = renderStyleMode P.style++-- | render the document with 'defaultMode'.+render :: Doc -> String+render = renderWithMode defaultMode++-- | pretty-print with a given style and mode.+prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String+prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty++-- | pretty-print with the default style and a given mode.+prettyPrintWithMode :: Pretty a => PPHsMode -> Int -> a -> String+prettyPrintWithMode mode lineLength = prettyPrintStyleMode P.style{P.lineLength = lineLength} mode++-- | pretty-print with the default style and 'defaultMode'.+prettyPrint :: Pretty a => Int -> a -> String+prettyPrint lineLength = prettyPrintWithMode defaultMode lineLength++fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->+ (P.TextDetails -> a -> a) -> a -> Doc -> a+fullRenderWithMode ppMode m i f fn e mD =+ P.fullRender m i f fn e $ (unDocM mD) ppMode+++fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)+ -> a -> Doc -> a+fullRender = fullRenderWithMode defaultMode++------------------------- Pretty-Print a Module --------------------+instance Pretty Module where+ pretty (Module pos m os mbWarn mbExports imp decls) =+ markLine pos $+ myVcat $ map pretty os +++ (if m == ModuleName "" then id+ else \x -> [topLevel (ppModuleHeader m mbWarn mbExports) x])+ (map pretty imp ++ map pretty decls)++-------------------------- Module Header ------------------------------+ppModuleHeader :: ModuleName -> Maybe WarningText -> Maybe [ExportSpec] -> Doc+ppModuleHeader m mbWarn mbExportList = mySep [+ text "module",+ pretty m,+ maybePP ppWarnTxt mbWarn,+ maybePP (parenList . map pretty) mbExportList,+ text "where"]++ppWarnTxt :: WarningText -> Doc+ppWarnTxt (DeprText s) = mySep [text "{-# DEPRECATED", text s, text "#-}"]+ppWarnTxt (WarnText s) = mySep [text "{-# WARNING", text s, text "#-}"]++instance Pretty ModuleName where+ pretty (ModuleName modName) = text modName++instance Pretty ExportSpec where+ pretty (EVar name) = pretty name+ pretty (EAbs name) = pretty name+ pretty (EThingAll name) = pretty name <> text "(..)"+ pretty (EThingWith name nameList) =+ pretty name <> (parenList . map pretty $ nameList)+ pretty (EModuleContents m) = text "module" <+> pretty m++instance Pretty ImportDecl where+ pretty (ImportDecl pos m qual src mbPkg mbName mbSpecs) =+ markLine pos $+ mySep [text "import",+ if src then text "{-# SOURCE #-}" else empty,+ if qual then text "qualified" else empty,+ maybePP (\s -> text (show s)) mbPkg,+ pretty m,+ maybePP (\m' -> text "as" <+> pretty m') mbName,+ maybePP exports mbSpecs]+ where+ exports (b,specList) =+ if b then text "hiding" <+> specs else specs+ where specs = parenList . map pretty $ specList++instance Pretty ImportSpec where+ pretty (IVar name) = pretty name+ pretty (IAbs name) = pretty name+ pretty (IThingAll name) = pretty name <> text "(..)"+ pretty (IThingWith name nameList) =+ pretty name <> (parenList . map pretty $ nameList)++------------------------- Declarations ------------------------------+instance Pretty Decl where+ pretty (TypeDecl loc name nameList htype) =+ blankline $+ markLine loc $+ mySep ( [text "type", pretty name]+ ++ map pretty nameList+ ++ [equals, pretty htype])++ pretty (DataDecl loc don context name nameList constrList derives) =+ blankline $+ markLine loc $+ mySep ( [pretty don, ppContext context, pretty name]+ ++ map pretty nameList)+ <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+ (map pretty constrList))+ $$$ ppDeriving derives)++ pretty (GDataDecl loc don context name nameList optkind gadtList derives) =+ blankline $+ markLine loc $+ mySep ( [pretty don, ppContext context, pretty name]+ ++ map pretty nameList ++ ppOptKind optkind ++ [text "where"])+ $$$ ppBody classIndent (map pretty gadtList)+ $$$ ppDeriving derives++ pretty (TypeFamDecl loc name nameList optkind) =+ blankline $+ markLine loc $+ mySep ([text "type", text "family", pretty name]+ ++ map pretty nameList+ ++ ppOptKind optkind)++ pretty (DataFamDecl loc context name nameList optkind) =+ blankline $+ markLine loc $+ mySep ( [text "data", text "family", ppContext context, pretty name]+ ++ map pretty nameList ++ ppOptKind optkind)++ pretty (TypeInsDecl loc ntype htype) =+ blankline $+ markLine loc $+ mySep [text "type", text "instance", pretty ntype, equals, pretty htype]++ pretty (DataInsDecl loc don ntype constrList derives) =+ blankline $+ markLine loc $+ mySep [pretty don, text "instance", pretty ntype]+ <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+ (map pretty constrList))+ $$$ ppDeriving derives)++ pretty (GDataInsDecl loc don ntype optkind gadtList derives) =+ blankline $+ markLine loc $+ mySep ( [pretty don, text "instance", pretty ntype]+ ++ ppOptKind optkind ++ [text "where"])+ $$$ ppBody classIndent (map pretty gadtList)+ $$$ ppDeriving derives++ --m{spacing=False}+ -- special case for empty class declaration+ pretty (ClassDecl pos context name nameList fundeps []) =+ blankline $+ markLine pos $+ mySep ( [text "class", ppContext context, pretty name]+ ++ map pretty nameList ++ [ppFunDeps fundeps])+ pretty (ClassDecl pos context name nameList fundeps declList) =+ blankline $+ markLine pos $+ mySep ( [text "class", ppContext context, pretty name]+ ++ map pretty nameList ++ [ppFunDeps fundeps, text "where"])+ $$$ ppBody classIndent (map pretty declList)++ -- m{spacing=False}+ -- special case for empty instance declaration+ pretty (InstDecl pos context name args []) =+ blankline $+ markLine pos $+ mySep ( [text "instance", ppContext context, pretty name]+ ++ map ppAType args)+ pretty (InstDecl pos context name args declList) =+ blankline $+ markLine pos $+ mySep ( [text "instance", ppContext context, pretty name]+ ++ map ppAType args ++ [text "where"])+ $$$ ppBody classIndent (map pretty declList)++ pretty (DerivDecl pos context name args) =+ blankline $+ markLine pos $+ mySep ( [text "deriving", text "instance", ppContext context, pretty name]+ ++ map ppAType args)+ pretty (DefaultDecl pos htypes) =+ blankline $+ markLine pos $+ text "default" <+> parenList (map pretty htypes)++ pretty (SpliceDecl pos splice) =+ blankline $+ markLine pos $+ pretty splice++ pretty (TypeSig pos nameList qualType) =+ blankline $+ markLine pos $+ mySep ((punctuate comma . map pretty $ nameList)+ ++ [text "::", pretty qualType])++ pretty (FunBind matches) = do+ e <- fmap layout getPPEnv+ case e of PPOffsideRule -> foldr ($$$) empty (map pretty matches)+ _ -> foldr (\x y -> x <> semi <> y) empty (map pretty matches)++ pretty (PatBind pos pat optsig rhs whereBinds) =+ markLine pos $+ myFsep [pretty pat, maybePP ppSig optsig, pretty rhs] $$$ ppWhere whereBinds++ pretty (InfixDecl pos assoc prec opList) =+ blankline $+ markLine pos $+ mySep ([pretty assoc, int prec]+ ++ (punctuate comma . map pretty $ opList))++ pretty (ForImp pos cconv saf str name typ) =+ blankline $+ markLine pos $+ mySep [text "foreign import", pretty cconv, pretty saf,+ text (show str), pretty name, text "::", pretty typ]++ pretty (ForExp pos cconv str name typ) =+ blankline $+ markLine pos $+ mySep [text "foreign export", pretty cconv,+ text (show str), pretty name, text "::", pretty typ]++ pretty (RulePragmaDecl pos rules) =+ blankline $+ markLine pos $+ myVcat $ text "{-# RULES" : map pretty rules ++ [text " #-}"]++ pretty (DeprPragmaDecl pos deprs) =+ blankline $+ markLine pos $+ myVcat $ text "{-# DEPRECATED" : map ppWarnDepr deprs ++ [text " #-}"]++ pretty (WarnPragmaDecl pos deprs) =+ blankline $+ markLine pos $+ myVcat $ text "{-# WARNING" : map ppWarnDepr deprs ++ [text " #-}"]++ pretty (InlineSig pos inl activ name) =+ blankline $+ markLine pos $+ mySep [text (if inl then "{-# INLINE" else "{-# NOINLINE"), pretty activ, pretty name, text "#-}"]++ pretty (InlineConlikeSig pos activ name) =+ blankline $+ markLine pos $+ mySep [text "{-# INLINE_CONLIKE", pretty activ, pretty name, text "#-}"]++ pretty (SpecSig pos name types) =+ blankline $+ markLine pos $+ mySep $ [text "{-# SPECIALISE", pretty name, text "::"]+ ++ punctuate comma (map pretty types) ++ [text "#-}"]++ pretty (SpecInlineSig pos inl activ name types) =+ blankline $+ markLine pos $+ mySep $ [text "{-# SPECIALISE", text (if inl then "INLINE" else "NOINLINE"),+ pretty activ, pretty name, text "::"]+ ++ (punctuate comma $ map pretty types) ++ [text "#-}"]++ pretty (InstSig pos context name args) =+ blankline $+ markLine pos $+ mySep $ [text "{-# SPECIALISE", text "instance", ppContext context, pretty name]+ ++ map ppAType args ++ [text "#-}"]++ pretty (AnnPragma pos ann) =+ blankline $+ markLine pos $+ mySep $ [text "{-# ANN", pretty ann, text "#-}"]++instance Pretty Annotation where+ pretty (Ann n e) = myFsep [pretty n, pretty e]+ pretty (TypeAnn n e) = myFsep [text "type", pretty n, pretty e]+ pretty (ModuleAnn e) = myFsep [text "module", pretty e]++instance Pretty DataOrNew where+ pretty DataType = text "data"+ pretty NewType = text "newtype"++instance Pretty Assoc where+ pretty AssocNone = text "infix"+ pretty AssocLeft = text "infixl"+ pretty AssocRight = text "infixr"++instance Pretty Match where+ pretty (Match pos f ps optsig rhs whereBinds) =+ markLine pos $+ myFsep (lhs ++ [maybePP ppSig optsig, pretty rhs])+ $$$ ppWhere whereBinds+ where+ lhs = case ps of+ l:r:ps' | isSymbolName f ->+ let hd = [pretty l, ppName f, pretty r] in+ if null ps' then hd+ else parens (myFsep hd) : map (prettyPrec 2) ps'+ _ -> pretty f : map (prettyPrec 2) ps++ppWhere :: Binds -> Doc+ppWhere (BDecls []) = empty+ppWhere (BDecls l) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))+ppWhere (IPBinds b) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty b))++ppSig :: Type -> Doc+ppSig t = text "::" <+> pretty t++instance Pretty ClassDecl where+ pretty (ClsDecl decl) = pretty decl++ pretty (ClsDataFam loc context name nameList optkind) =+ markLine loc $+ mySep ( [text "data", ppContext context, pretty name]+ ++ map pretty nameList ++ ppOptKind optkind)++ pretty (ClsTyFam loc name nameList optkind) =+ markLine loc $+ mySep ( [text "type", pretty name]+ ++ map pretty nameList ++ ppOptKind optkind)++ pretty (ClsTyDef loc ntype htype) =+ markLine loc $+ mySep [text "type", pretty ntype, equals, pretty htype]++instance Pretty InstDecl where+ pretty (InsDecl decl) = pretty decl++ pretty (InsType loc ntype htype) =+ markLine loc $+ mySep [text "type", pretty ntype, equals, pretty htype]++ pretty (InsData loc don ntype constrList derives) =+ markLine loc $+ mySep [pretty don, pretty ntype]+ <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+ (map pretty constrList))+ $$$ ppDeriving derives)++ pretty (InsGData loc don ntype optkind gadtList derives) =+ markLine loc $+ mySep ( [pretty don, pretty ntype]+ ++ ppOptKind optkind ++ [text "where"])+ $$$ ppBody classIndent (map pretty gadtList)+ $$$ ppDeriving derives++-- pretty (InsInline loc inl activ name) =+-- markLine loc $+-- mySep [text (if inl then "{-# INLINE" else "{-# NOINLINE"), pretty activ, pretty name, text "#-}"]+++------------------------- FFI stuff -------------------------------------+instance Pretty Safety where+ pretty PlayRisky = text "unsafe"+ pretty (PlaySafe b) = text $ if b then "threadsafe" else "safe"++instance Pretty CallConv where+ pretty StdCall = text "stdcall"+ pretty CCall = text "ccall"++------------------------- Pragmas ---------------------------------------+ppWarnDepr :: ([Name], String) -> Doc+ppWarnDepr (names, txt) = mySep $ (punctuate comma $ map pretty names) ++ [text $ show txt]++instance Pretty Rule where+ pretty (Rule tag activ rvs rhs lhs) =+ mySep $ [text $ show tag, pretty activ,+ maybePP ppRuleVars rvs,+ pretty rhs, char '=', pretty lhs]++ppRuleVars :: [RuleVar] -> Doc+ppRuleVars [] = empty+ppRuleVars rvs = mySep $ text "forall" : map pretty rvs ++ [char '.']++instance Pretty Activation where+ pretty AlwaysActive = empty+ pretty (ActiveFrom i) = char '[' <> int i <> char ']'+ pretty (ActiveUntil i) = text "[~" <> int i <> char ']'++instance Pretty RuleVar where+ pretty (RuleVar n) = pretty n+ pretty (TypedRuleVar n t) = mySep [pretty n, text "::", pretty t]++instance Pretty ModulePragma where+ pretty (LanguagePragma _ ns) =+ myFsep $ text "{-# LANGUAGE" : punctuate (char ',') (map pretty ns) ++ [text "#-}"]+ pretty (OptionsPragma _ (Just tool) s) =+ myFsep $ [text "{-# OPTIONS_" <> pretty tool, text s, text "#-}"]+ pretty (OptionsPragma _ _ s) =+ myFsep $ [text "{-# OPTIONS", text s, text "#-}"]+ pretty (AnnModulePragma _ ann) =+ myFsep $ [text "{-# ANN", pretty ann, text "#-}"]+ ++instance Pretty Tool where+ pretty (UnknownTool s) = text s+ pretty t = text $ show t++------------------------- Data & Newtype Bodies -------------------------+instance Pretty QualConDecl where+ pretty (QualConDecl _pos tvs ctxt con) =+ myFsep [ppForall (Just tvs), ppContext ctxt, pretty con]++instance Pretty GadtDecl where+ pretty (GadtDecl _pos name ty) =+ myFsep [pretty name, text "::", pretty ty]++instance Pretty ConDecl where+ pretty (RecDecl name fieldList) =+ pretty name <> (braceList . map ppField $ fieldList)++{- pretty (ConDecl name@(Symbol _) [l, r]) =+ myFsep [prettyPrec prec_btype l, ppName name,+ prettyPrec prec_btype r] -}+ pretty (ConDecl name typeList) =+ mySep $ ppName name : map (prettyPrec prec_atype) typeList+ pretty (InfixConDecl l name r) =+ myFsep [prettyPrec prec_btype l, ppNameInfix name,+ prettyPrec prec_btype r]++ppField :: ([Name],BangType) -> Doc+ppField (names, ty) =+ myFsepSimple $ (punctuate comma . map pretty $ names) +++ [text "::", pretty ty]++instance Pretty BangType where+ prettyPrec _ (BangedTy ty) = char '!' <> ppAType ty+ prettyPrec p (UnBangedTy ty) = prettyPrec p ty+ prettyPrec p (UnpackedTy ty) = text "{-# UNPACK #-}" <+> char '!' <> prettyPrec p ty++ppDeriving :: [Deriving] -> Doc+ppDeriving [] = empty+ppDeriving [(d, [])] = text "deriving" <+> ppQName d+ppDeriving ds = text "deriving" <+> parenList (map ppDer ds)+ where ppDer :: (QName, [Type]) -> Doc+ ppDer (n, ts) = mySep (pretty n : map pretty ts)++------------------------- Types -------------------------+ppBType :: Type -> Doc+ppBType = prettyPrec prec_btype++ppAType :: Type -> Doc+ppAType = prettyPrec prec_atype++-- precedences for types+prec_btype, prec_atype :: Int+prec_btype = 1 -- left argument of ->,+ -- or either argument of an infix data constructor+prec_atype = 2 -- argument of type or data constructor, or of a class++instance Pretty Type where+ prettyPrec p (TyForall mtvs ctxt htype) = parensIf (p > 0) $+ myFsep [ppForall mtvs, ppContext ctxt, pretty htype]+ prettyPrec p (TyFun a b) = parensIf (p > 0) $+ myFsep [ppBType a, text "->", pretty b]+ prettyPrec _ (TyTuple bxd l) =+ let ds = map pretty l+ in case bxd of+ Boxed -> parenList ds+ Unboxed -> hashParenList ds+ prettyPrec _ (TyList t) = brackets $ pretty t+ prettyPrec p (TyApp a b) =+ {-+ | a == list_tycon = brackets $ pretty b -- special case+ | otherwise = -} parensIf (p > prec_btype) $+ myFsep [pretty a, ppAType b]+ prettyPrec _ (TyVar name) = pretty name+ prettyPrec _ (TyCon name) = pretty name+ prettyPrec _ (TyParen t) = parens (pretty t)+-- prettyPrec _ (TyPred asst) = pretty asst+ prettyPrec _ (TyInfix a op b) = myFsep [pretty a, ppQNameInfix op, pretty b]+ prettyPrec _ (TyKind t k) = parens (myFsep [pretty t, text "::", pretty k])+++instance Pretty TyVarBind where+ pretty (KindedVar var kind) = parens $ myFsep [pretty var, text "::", pretty kind]+ pretty (UnkindedVar var) = pretty var++ppForall :: Maybe [TyVarBind] -> Doc+ppForall Nothing = empty+ppForall (Just []) = empty+ppForall (Just vs) = myFsep (text "forall" : map pretty vs ++ [char '.'])++---------------------------- Kinds ----------------------------++instance Pretty Kind where+ pretty KindStar = text "*"+ pretty KindBang = text "!"+ pretty (KindFn a b) = myFsep [pretty a, text "->", pretty b]+ pretty (KindParen k) = parens $ pretty k+ pretty (KindVar n) = pretty n++ppOptKind :: Maybe Kind -> [Doc]+ppOptKind Nothing = []+ppOptKind (Just k) = [text "::", pretty k]++------------------- Functional Dependencies -------------------+instance Pretty FunDep where+ pretty (FunDep from to) =+ myFsep $ map pretty from ++ [text "->"] ++ map pretty to+++ppFunDeps :: [FunDep] -> Doc+ppFunDeps [] = empty+ppFunDeps fds = myFsep $ (char '|':) . punctuate comma . map pretty $ fds++------------------------- Expressions -------------------------+instance Pretty Rhs where+ pretty (UnGuardedRhs e) = equals <+> pretty e+ pretty (GuardedRhss guardList) = myVcat . map pretty $ guardList++instance Pretty GuardedRhs where+ pretty (GuardedRhs _pos guards ppBody) =+ myFsep $ [char '|'] ++ (punctuate comma . map pretty $ guards) ++ [equals, pretty ppBody]++instance Pretty Literal where+ pretty (Int i) = integer i+ pretty (Char c) = text (show c)+ pretty (String s) = text (show s)+ pretty (Frac r) = double (fromRational r)+ -- GHC unboxed literals:+ pretty (PrimChar c) = text (show c) <> char '#'+ pretty (PrimString s) = text (show s) <> char '#'+ pretty (PrimInt i) = integer i <> char '#'+ pretty (PrimWord w) = integer w <> text "##"+ pretty (PrimFloat r) = float (fromRational r) <> char '#'+ pretty (PrimDouble r) = double (fromRational r) <> text "##"++instance Pretty Exp where+ prettyPrec _ (Lit l) = pretty l+ -- lambda stuff+ prettyPrec p (InfixApp a op b) = parensIf (p > 0) $ myFsep [pretty a, pretty op, pretty b]+ prettyPrec _ (NegApp e) = parens $ myFsep [char '-', pretty e]+ prettyPrec p (App a b) = parensIf (p > 0) $ myFsep [pretty a, prettyPrec 1 b]+ prettyPrec p (Lambda _loc expList ppBody) = parensIf (p > 0) $ myFsep $+ char '\\' : map pretty expList ++ [text "->", pretty ppBody]+ -- keywords+ -- two cases for lets+ prettyPrec p (Let (BDecls declList) letBody) =+ parensIf (p > 0) $ ppLetExp declList letBody+ prettyPrec p (Let (IPBinds bindList) letBody) =+ parensIf (p > 0) $ ppLetExp bindList letBody++ prettyPrec p (If cond thenexp elsexp) = parensIf (p > 0) $+ myFsep [text "if", pretty cond,+ text "then", pretty thenexp,+ text "else", pretty elsexp]+ prettyPrec p (Case cond altList) = parensIf (p > 0) $+ myFsep [text "case", pretty cond, text "of"]+ $$$ ppBody caseIndent (map pretty altList)+ prettyPrec p (Do stmtList) = parensIf (p > 0) $ + text "do" $$$ ppBody doIndent (map pretty stmtList)+ prettyPrec p (MDo stmtList) = parensIf (p > 0) $ + text "mdo" $$$ ppBody doIndent (map pretty stmtList)+ -- Constructors & Vars+ prettyPrec _ (Var name) = pretty name+ prettyPrec _ (IPVar ipname) = pretty ipname+ prettyPrec _ (Con name) = pretty name+ prettyPrec _ (Tuple expList) = parenList . map pretty $ expList+ prettyPrec _ (TupleSection mExpList) = parenList . map (maybePP pretty) $ mExpList+ -- weird stuff+ prettyPrec _ (Paren e) = case e of+ SCCPragma _ _ -> pretty e+ otherwise -> parens . pretty $ e+ prettyPrec _ (LeftSection e op) = parens (pretty e <+> pretty op)+ prettyPrec _ (RightSection op e) = parens (pretty op <+> pretty e)+ prettyPrec _ (RecConstr c fieldList) =+ pretty c <> (braceList . map pretty $ fieldList)+ prettyPrec _ (RecUpdate e fieldList) =+ pretty e <> (braceList . map pretty $ fieldList)+ -- Lists+ prettyPrec _ (List list) =+ bracketList . punctuate comma . map pretty $ list+ prettyPrec _ (EnumFrom e) =+ bracketList [pretty e, text ".."]+ prettyPrec _ (EnumFromTo from to) =+ bracketList [pretty from, text "..", pretty to]+ prettyPrec _ (EnumFromThen from thenE) =+ bracketList [pretty from <> comma, pretty thenE, text ".."]+ prettyPrec _ (EnumFromThenTo from thenE to) =+ bracketList [pretty from <> comma, pretty thenE,+ text "..", pretty to]+ prettyPrec _ (ListComp e qualList) =+ bracketList ([pretty e, char '|']+ ++ (punctuate comma . map pretty $ qualList))+ prettyPrec _ (ParComp e qualLists) =+ bracketList (intersperse (char '|') $+ pretty e : (punctuate comma . concatMap (map pretty) $ qualLists))+ prettyPrec p (ExpTypeSig _pos e ty) = parensIf (p > 0) $ + myFsep [pretty e, text "::", pretty ty]+ -- Template Haskell+ prettyPrec _ (BracketExp b) = pretty b+ prettyPrec _ (SpliceExp s) = pretty s+ prettyPrec _ (TypQuote t) = text "\'\'" <> pretty t+ prettyPrec _ (VarQuote x) = text "\'" <> pretty x+ prettyPrec _ (QuasiQuote n qt) = text ("[$" ++ n ++ "|" ++ qt ++ "|]")+ -- Hsx+ prettyPrec _ (XTag _ n attrs mattr cs) =+ let ax = maybe [] (return . pretty) mattr+ in hcat $+ (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):+ map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]+ prettyPrec _ (XETag _ n attrs mattr) =+ let ax = maybe [] (return . pretty) mattr+ in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]+ prettyPrec _ (XPcdata s) = text s+ prettyPrec _ (XExpTag e) =+ myFsep $ [text "<%", pretty e, text "%>"]+ -- Pragmas+ prettyPrec p (CorePragma s e) = myFsep $ map text ["{-# CORE", show s, "#-}"] ++ [pretty e]+ prettyPrec _ (SCCPragma s e) = zeroWidthText "<a class=info href=\"#\"><span>" <> zeroWidthText s <> zeroWidthText "</span><font style=\"background-color: #" <> zeroWidthText s <> zeroWidthText "\">" <> pretty e <> zeroWidthText "</font></a>"+ prettyPrec _ (GenPragma s (a,b) (c,d) e) =+ myFsep $ [text "{-# GENERATED", text $ show s,+ int a, char ':', int b, char '-',+ int c, char ':', int d, text "#-}", pretty e]+ -- Arrows+ prettyPrec p (Proc _ pat e) = parensIf (p > 0) $ myFsep $ [text "proc", pretty pat, text "->", pretty e]+ prettyPrec p (LeftArrApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text "-<", pretty r]+ prettyPrec p (RightArrApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text ">-", pretty r]+ prettyPrec p (LeftArrHighApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text "-<<", pretty r]+ prettyPrec p (RightArrHighApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text ">>-", pretty r]+++instance Pretty XAttr where+ pretty (XAttr n v) =+ myFsep [pretty n, char '=', pretty v]++instance Pretty XName where+ pretty (XName n) = text n+ pretty (XDomName d n) = text d <> char ':' <> text n++--ppLetExp :: [Decl] -> Exp -> Doc+ppLetExp l b = myFsep [text "let" <+> ppBody letIndent (map pretty l),+ text "in", pretty b]++ppWith binds = nest 2 (text "with" $$$ ppBody withIndent (map pretty binds))+withIndent = whereIndent++--------------------- Template Haskell -------------------------++instance Pretty Bracket where+ pretty (ExpBracket e) = ppBracket "[|" e+ pretty (PatBracket p) = ppBracket "[p|" p+ pretty (TypeBracket t) = ppBracket "[t|" t+ pretty (DeclBracket d) =+ myFsep $ text "[d|" : map pretty d ++ [text "|]"]++ppBracket o x = myFsep [text o, pretty x, text "|]"]++instance Pretty Splice where+ pretty (IdSplice s) = char '$' <> text s+ pretty (ParenSplice e) =+ myFsep [text "$(", pretty e, char ')']++------------------------- Patterns -----------------------------++instance Pretty Pat where+ prettyPrec _ (PVar name) = pretty name+ prettyPrec _ (PLit lit) = pretty lit+ prettyPrec _ (PNeg p) = myFsep [char '-', pretty p]+ prettyPrec p (PInfixApp a op b) = parensIf (p > 0) $+ myFsep [pretty a, pretty (QConOp op), pretty b]+ prettyPrec p (PApp n ps) = parensIf (p > 1) $+ myFsep (pretty n : map pretty ps)+ prettyPrec _ (PTuple ps) = parenList . map pretty $ ps+ prettyPrec _ (PList ps) =+ bracketList . punctuate comma . map pretty $ ps+ prettyPrec _ (PParen p) = parens . pretty $ p+ prettyPrec _ (PRec c fields) =+ pretty c <> (braceList . map pretty $ fields)+ -- special case that would otherwise be buggy+ prettyPrec _ (PAsPat name (PIrrPat pat)) =+ myFsep [pretty name <> char '@', char '~' <> pretty pat]+ prettyPrec _ (PAsPat name pat) =+ hcat [pretty name, char '@', pretty pat]+ prettyPrec _ PWildCard = char '_'+ prettyPrec _ (PIrrPat pat) = char '~' <> pretty pat+ prettyPrec _ (PatTypeSig _pos pat ty) =+ myFsep [pretty pat, text "::", pretty ty]+ prettyPrec p (PViewPat e pat) = parensIf (p > 0) $+ myFsep [pretty e, text "->", pretty pat]+ prettyPrec p (PNPlusK n k) = parensIf (p > 0) $+ myFsep [pretty n, text "+", text $ show k]+ -- HaRP+ prettyPrec _ (PRPat rs) =+ bracketList . punctuate comma . map pretty $ rs+ -- Hsx+ prettyPrec _ (PXTag _ n attrs mattr cp) =+ let ap = maybe [] (return . pretty) mattr+ in hcat $ -- TODO: should not introduce blanks+ (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [char '>']):+ map pretty cp ++ [myFsep $ [text "</" <> pretty n, char '>']]+ prettyPrec _ (PXETag _ n attrs mattr) =+ let ap = maybe [] (return . pretty) mattr+ in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [text "/>"]+ prettyPrec _ (PXPcdata s) = text s+ prettyPrec _ (PXPatTag p) =+ myFsep $ [text "<%", pretty p, text "%>"]+ prettyPrec _ (PXRPats ps) =+ myFsep $ text "<[" : map pretty ps ++ [text "%>"]+ -- Generics+ prettyPrec _ (PExplTypeArg qn t) =+ myFsep [pretty qn, text "{|", pretty t, text "|}"]+ -- BangPatterns+ prettyPrec _ (PBangPat p) = text "!" <> pretty p++instance Pretty PXAttr where+ pretty (PXAttr n p) =+ myFsep [pretty n, char '=', pretty p]++instance Pretty PatField where+ pretty (PFieldPat name pat) =+ myFsep [pretty name, equals, pretty pat]+ pretty (PFieldPun name) = pretty name+ pretty (PFieldWildcard) = text ".."++--------------------- Regular Patterns -------------------------++instance Pretty RPat where+ pretty (RPOp r op) = pretty r <> pretty op+ pretty (RPEither r1 r2) = parens . myFsep $+ [pretty r1, char '|', pretty r2]+ pretty (RPSeq rs) =+ myFsep $ text "(/" : map pretty rs ++ [text "/)"]+ pretty (RPGuard r gs) =+ myFsep $ text "(|" : pretty r : char '|' : map pretty gs ++ [text "|)"]+ -- special case that would otherwise be buggy+ pretty (RPCAs n (RPPat (PIrrPat p))) =+ myFsep [pretty n <> text "@:", char '~' <> pretty p]+ pretty (RPCAs n r) = hcat [pretty n, text "@:", pretty r]+ -- special case that would otherwise be buggy+ pretty (RPAs n (RPPat (PIrrPat p))) =+ myFsep [pretty n <> text "@:", char '~' <> pretty p]+ pretty (RPAs n r) = hcat [pretty n, char '@', pretty r]+ pretty (RPPat p) = pretty p+ pretty (RPParen rp) = parens . pretty $ rp++instance Pretty RPatOp where+ pretty RPStar = char '*'+ pretty RPStarG = text "*!"+ pretty RPPlus = char '+'+ pretty RPPlusG = text "+!"+ pretty RPOpt = char '?'+ pretty RPOptG = text "?!"++------------------------- Case bodies -------------------------+instance Pretty Alt where+ pretty (Alt _pos e gAlts binds) =+ pretty e <+> pretty gAlts $$$ ppWhere binds++instance Pretty GuardedAlts where+ pretty (UnGuardedAlt e) = text "->" <+> pretty e+ pretty (GuardedAlts altList) = myVcat . map pretty $ altList++instance Pretty GuardedAlt where+ pretty (GuardedAlt _pos guards body) =+ myFsep $ char '|': (punctuate comma . map pretty $ guards) ++ [text "->", pretty body]++------------------------- Statements in monads, guards & list comprehensions -----+instance Pretty Stmt where+ pretty (Generator _loc e from) =+ pretty e <+> text "<-" <+> pretty from+ pretty (Qualifier e) = pretty e+ -- two cases for lets+ pretty (LetStmt (BDecls declList)) =+ ppLetStmt declList+ pretty (LetStmt (IPBinds bindList)) =+ ppLetStmt bindList+ pretty (RecStmt stmtList) =+ text "rec" $$$ ppBody letIndent (map pretty stmtList)++ppLetStmt l = text "let" $$$ ppBody letIndent (map pretty l)++instance Pretty QualStmt where+ pretty (QualStmt s) = pretty s+ pretty (ThenTrans f) = myFsep $ [text "then", pretty f]+ pretty (ThenBy f e) = myFsep $ [text "then", pretty f, text "by", pretty e]+ pretty (GroupBy e) = myFsep $ [text "then", text "group", text "by", pretty e]+ pretty (GroupUsing f) = myFsep $ [text "then", text "group", text "using", pretty f]+ pretty (GroupByUsing e f) = myFsep $ [text "then", text "group", text "by",+ pretty e, text "using", pretty f]++++------------------------- Record updates+instance Pretty FieldUpdate where+ pretty (FieldUpdate name e) =+ myFsep [pretty name, equals, pretty e]+ pretty (FieldPun name) = pretty name+ pretty (FieldWildcard) = text ".."++------------------------- Names -------------------------+instance Pretty QOp where+ pretty (QVarOp n) = ppQNameInfix n+ pretty (QConOp n) = ppQNameInfix n++ppQNameInfix :: QName -> Doc+ppQNameInfix name+ | isSymbolName (getName name) = ppQName name+ | otherwise = char '`' <> ppQName name <> char '`'++instance Pretty QName where+ pretty name = case name of+ UnQual (Symbol ('#':_)) -> char '(' <+> ppQName name <+> char ')'+ _ -> parensIf (isSymbolName (getName name)) (ppQName name)++ppQName :: QName -> Doc+ppQName (UnQual name) = ppName name+ppQName (Qual m name) = pretty m <> char '.' <> ppName name+ppQName (Special sym) = text (specialName sym)++instance Pretty Op where+ pretty (VarOp n) = ppNameInfix n+ pretty (ConOp n) = ppNameInfix n++ppNameInfix :: Name -> Doc+ppNameInfix name+ | isSymbolName name = ppName name+ | otherwise = char '`' <> ppName name <> char '`'++instance Pretty Name where+ pretty name = case name of+ Symbol ('#':_) -> char '(' <+> ppName name <+> char ')'+ _ -> parensIf (isSymbolName name) (ppName name)++ppName :: Name -> Doc+ppName (Ident s) = text s+ppName (Symbol s) = text s++instance Pretty IPName where+ pretty (IPDup s) = char '?' <> text s+ pretty (IPLin s) = char '%' <> text s++instance Pretty IPBind where+ pretty (IPBind _loc ipname exp) =+ myFsep [pretty ipname, equals, pretty exp]++instance Pretty CName where+ pretty (VarName n) = pretty n+ pretty (ConName n) = pretty n++instance Pretty SpecialCon where+ pretty sc = text $ specialName sc++isSymbolName :: Name -> Bool+isSymbolName (Symbol _) = True+isSymbolName _ = False++getName :: QName -> Name+getName (UnQual s) = s+getName (Qual _ s) = s+getName (Special Cons) = Symbol ":"+getName (Special FunCon) = Symbol "->"+getName (Special s) = Ident (specialName s)++specialName :: SpecialCon -> String+specialName UnitCon = "()"+specialName ListCon = "[]"+specialName FunCon = "->"+specialName (TupleCon b n) = "(" ++ hash ++ replicate (n-1) ',' ++ hash ++ ")"+ where hash = if b == Unboxed then "#" else ""+specialName Cons = ":"++ppContext :: Context -> Doc+ppContext [] = empty+ppContext context = mySep [parenList (map pretty context), text "=>"]++-- hacked for multi-parameter type classes+instance Pretty Asst where+ pretty (ClassA a ts) = myFsep $ ppQName a : map ppAType ts+ pretty (InfixA a op b) = myFsep $ [pretty a, ppQNameInfix op, pretty b]+ pretty (IParam i t) = myFsep $ [pretty i, text "::", pretty t]+ pretty (EqualP t1 t2) = myFsep $ [pretty t1, text "~", pretty t2]++-- Pretty print a source location, useful for printing out error messages+instance Pretty SrcLoc where+ pretty srcLoc =+ return $ P.hsep [ colonFollow (P.text $ srcFilename srcLoc)+ , colonFollow (P.int $ srcLine srcLoc)+ , P.int $ srcColumn srcLoc+ ]++colonFollow p = P.hcat [ p, P.colon ]+++instance Pretty SrcSpan where+ pretty srcSpan =+ return $ P.hsep [ colonFollow (P.text $ srcSpanFilename srcSpan)+ , P.hcat [ P.text "("+ , P.int $ srcSpanStartLine srcSpan+ , P.colon+ , P.int $ srcSpanStartColumn srcSpan+ , P.text ")"+ ]+ , P.text "-"+ , P.hcat [ P.text "("+ , P.int $ srcSpanEndLine srcSpan+ , P.colon+ , P.int $ srcSpanEndColumn srcSpan+ , P.text ")"+ ]+ ]++---------------------------------------------------------------------+-- Annotated version++------------------------- Pretty-Print a Module --------------------+instance SrcInfo pos => Pretty (A.Module pos) where+ pretty (A.Module pos mbHead os imp decls) =+ markLine pos $+ myVcat $ map pretty os +++ (case mbHead of+ Nothing -> id+ Just h -> \x -> [topLevel (pretty h) x])+ (map pretty imp ++ map pretty decls)+ pretty (A.XmlPage pos _mn os n attrs mattr cs) =+ markLine pos $+ myVcat $ map pretty os +++ [let ax = maybe [] (return . pretty) mattr+ in hcat $+ (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):+ map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]]+ pretty (A.XmlHybrid pos mbHead os imp decls n attrs mattr cs) =+ markLine pos $+ myVcat $ map pretty os ++ [text "<%"] +++ (case mbHead of+ Nothing -> id+ Just h -> \x -> [topLevel (pretty h) x])+ (map pretty imp ++ map pretty decls +++ [let ax = maybe [] (return . pretty) mattr+ in hcat $+ (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):+ map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]])++++-------------------------- Module Header ------------------------------+instance Pretty (A.ModuleHead l) where+ pretty (A.ModuleHead _ m mbWarn mbExportList) = mySep [+ text "module",+ pretty m,+ maybePP pretty mbWarn,+ maybePP pretty mbExportList,+ text "where"]++instance Pretty (A.WarningText l) where+ pretty = ppWarnTxt. sWarningText++instance Pretty (A.ModuleName l) where+ pretty = pretty . sModuleName++instance Pretty (A.ExportSpecList l) where+ pretty (A.ExportSpecList _ especs) = parenList $ map pretty especs++instance Pretty (A.ExportSpec l) where+ pretty = pretty . sExportSpec++instance SrcInfo pos => Pretty (A.ImportDecl pos) where+ pretty = pretty . sImportDecl++instance Pretty (A.ImportSpecList l) where+ pretty (A.ImportSpecList _ b ispecs) =+ (if b then text "hiding" else empty)+ <+> parenList (map pretty ispecs)++instance Pretty (A.ImportSpec l) where+ pretty = pretty . sImportSpec++------------------------- Declarations ------------------------------+instance SrcInfo pos => Pretty (A.Decl pos) where+ pretty = pretty . sDecl++instance Pretty (A.DeclHead l) where+ pretty (A.DHead l n tvs) = mySep (pretty n : map pretty tvs)+ pretty (A.DHInfix l tva n tvb) = mySep [pretty tva, pretty n, pretty tvb]+ pretty (A.DHParen l dh) = parens (pretty dh)++instance Pretty (A.InstHead l) where+ pretty (A.IHead l qn ts) = mySep (pretty qn : map pretty ts)+ pretty (A.IHInfix l ta qn tb) = mySep [pretty ta, pretty qn, pretty tb]+ pretty (A.IHParen l ih) = parens (pretty ih)++instance Pretty (A.DataOrNew l) where+ pretty = pretty . sDataOrNew++instance Pretty (A.Assoc l) where+ pretty = pretty . sAssoc++instance SrcInfo pos => Pretty (A.Match pos) where+ pretty = pretty . sMatch++instance SrcInfo loc => Pretty (A.ClassDecl loc) where+ pretty = pretty . sClassDecl++instance SrcInfo loc => Pretty (A.InstDecl loc) where+ pretty = pretty . sInstDecl++------------------------- FFI stuff -------------------------------------+instance Pretty (A.Safety l) where+ pretty = pretty . sSafety++instance Pretty (A.CallConv l) where+ pretty = pretty . sCallConv++------------------------- Pragmas ---------------------------------------+instance SrcInfo loc => Pretty (A.Rule loc) where+ pretty = pretty . sRule++instance Pretty (A.Activation l) where+ pretty = pretty . sActivation++instance Pretty (A.RuleVar l) where+ pretty = pretty . sRuleVar++instance SrcInfo loc => Pretty (A.ModulePragma loc) where+ pretty (A.LanguagePragma _ ns) =+ myFsep $ text "{-# LANGUAGE" : punctuate (char ',') (map pretty ns) ++ [text "#-}"]+ pretty (A.OptionsPragma _ (Just tool) s) =+ myFsep $ [text "{-# OPTIONS_" <> pretty tool, text s, text "#-}"]+ pretty (A.OptionsPragma _ _ s) =+ myFsep $ [text "{-# OPTIONS", text s, text "#-}"]+ pretty (A.AnnModulePragma _ ann) =+ myFsep $ [text "{-# ANN", pretty ann, text "#-}"]++instance SrcInfo loc => Pretty (A.Annotation loc) where+ pretty = pretty . sAnnotation++------------------------- Data & Newtype Bodies -------------------------+instance Pretty (A.QualConDecl l) where+ pretty (A.QualConDecl _pos mtvs ctxt con) =+ myFsep [ppForall (fmap (map sTyVarBind) mtvs), ppContext $ maybe [] sContext ctxt, pretty con]++instance Pretty (A.GadtDecl l) where+ pretty (A.GadtDecl _pos name ty) =+ myFsep [pretty name, text "::", pretty ty]++instance Pretty (A.ConDecl l) where+ pretty = pretty . sConDecl++instance Pretty (A.FieldDecl l) where+ pretty (A.FieldDecl _ names ty) =+ myFsepSimple $ (punctuate comma . map pretty $ names) +++ [text "::", pretty ty]+++instance Pretty (A.BangType l) where+ pretty = pretty . sBangType++instance Pretty (A.Deriving l) where+ pretty (A.Deriving _ []) = text "deriving" <+> parenList []+ pretty (A.Deriving _ [A.IHead _ d []]) = text "deriving" <+> pretty d+ pretty (A.Deriving _ ihs) = text "deriving" <+> parenList (map pretty ihs)++------------------------- Types -------------------------+instance Pretty (A.Type l) where+ pretty = pretty . sType++instance Pretty (A.TyVarBind l) where+ pretty = pretty . sTyVarBind++---------------------------- Kinds ----------------------------++instance Pretty (A.Kind l) where+ pretty = pretty . sKind++------------------- Functional Dependencies -------------------+instance Pretty (A.FunDep l) where+ pretty = pretty . sFunDep++------------------------- Expressions -------------------------+instance SrcInfo loc => Pretty (A.Rhs loc) where+ pretty = pretty . sRhs++instance SrcInfo loc => Pretty (A.GuardedRhs loc) where+ pretty = pretty . sGuardedRhs++instance Pretty (A.Literal l) where+ pretty = pretty . sLiteral++instance SrcInfo loc => Pretty (A.Exp loc) where+ pretty = pretty . sExp++instance SrcInfo loc => Pretty (A.XAttr loc) where+ pretty = pretty . sXAttr++instance Pretty (A.XName l) where+ pretty = pretty . sXName++--------------------- Template Haskell -------------------------++instance SrcInfo loc => Pretty (A.Bracket loc) where+ pretty = pretty . sBracket++instance SrcInfo loc => Pretty (A.Splice loc) where+ pretty = pretty . sSplice++------------------------- Patterns -----------------------------++instance SrcInfo loc => Pretty (A.Pat loc) where+ pretty = pretty . sPat++instance SrcInfo loc => Pretty (A.PXAttr loc) where+ pretty = pretty . sPXAttr++instance SrcInfo loc => Pretty (A.PatField loc) where+ pretty = pretty . sPatField++--------------------- Regular Patterns -------------------------++instance SrcInfo loc => Pretty (A.RPat loc) where+ pretty = pretty . sRPat++instance Pretty (A.RPatOp l) where+ pretty = pretty . sRPatOp++------------------------- Case bodies -------------------------+instance SrcInfo loc => Pretty (A.Alt loc) where+ pretty = pretty . sAlt++instance SrcInfo loc => Pretty (A.GuardedAlts loc) where+ pretty = pretty . sGuardedAlts++instance SrcInfo loc => Pretty (A.GuardedAlt loc) where+ pretty = pretty . sGuardedAlt++------------------------- Statements in monads, guards & list comprehensions -----+instance SrcInfo loc => Pretty (A.Stmt loc) where+ pretty = pretty . sStmt++instance SrcInfo loc => Pretty (A.QualStmt loc) where+ pretty = pretty . sQualStmt++------------------------- Record updates+instance SrcInfo loc => Pretty (A.FieldUpdate loc) where+ pretty = pretty . sFieldUpdate++------------------------- Names -------------------------+instance Pretty (A.QOp l) where+ pretty = pretty . sQOp++instance Pretty (A.QName l) where+ pretty = pretty . sQName++instance Pretty (A.Op l) where+ pretty = pretty . sOp++instance Pretty (A.Name l) where+ pretty = pretty . sName++instance Pretty (A.IPName l) where+ pretty = pretty . sIPName++instance SrcInfo loc => Pretty (A.IPBind loc) where+ pretty = pretty . sIPBind++instance Pretty (A.CName l) where+ pretty = pretty . sCName++instance Pretty (A.Context l) where+ pretty (A.CxEmpty _) = mySep [text "()", text "=>"]+ pretty (A.CxSingle _ asst) = mySep [pretty asst, text "=>"]+ pretty (A.CxTuple _ assts) = myFsep $ [parenList (map pretty assts), text "=>"]+ pretty (A.CxParen _ asst) = parens (pretty asst)++-- hacked for multi-parameter type classes+instance Pretty (A.Asst l) where+ pretty = pretty . sAsst++------------------------- pp utils -------------------------+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP pp Nothing = empty+maybePP pp (Just a) = pp a++parenList :: [Doc] -> Doc+parenList = parens . myFsepSimple . punctuate comma++hashParenList :: [Doc] -> Doc+hashParenList = hashParens . myFsepSimple . punctuate comma+ where hashParens = parens . hashes+ hashes = \doc -> char '#' <> doc <> char '#'++braceList :: [Doc] -> Doc+braceList = braces . myFsepSimple . punctuate comma++bracketList :: [Doc] -> Doc+bracketList = brackets . myFsepSimple++-- Wrap in braces and semicolons, with an extra space at the start in+-- case the first doc begins with "-", which would be scanned as {-+flatBlock :: [Doc] -> Doc+flatBlock = braces . (space <>) . hsep . punctuate semi++-- Same, but put each thing on a separate line+prettyBlock :: [Doc] -> Doc+prettyBlock = braces . (space <>) . vcat . punctuate semi++-- Monadic PP Combinators -- these examine the env++blankline :: Doc -> Doc+blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout+ then space $$ dl else dl}+topLevel :: Doc -> [Doc] -> Doc+topLevel header dl = do+ e <- fmap layout getPPEnv+ case e of+ PPOffsideRule -> header $$ vcat dl+ PPSemiColon -> header $$ prettyBlock dl+ PPInLine -> header $$ prettyBlock dl+ PPNoLayout -> header <+> flatBlock dl++ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc+ppBody f dl = do+ e <- fmap layout getPPEnv+ case e of PPOffsideRule -> indent+ PPSemiColon -> indentExplicit+ _ -> flatBlock dl+ where+ indent = do{i <-fmap f getPPEnv;nest i . vcat $ dl}+ indentExplicit = do {i <- fmap f getPPEnv;+ nest i . prettyBlock $ dl}++($$$) :: Doc -> Doc -> Doc+a $$$ b = layoutChoice (a $$) (a <+>) b++mySep :: [Doc] -> Doc+mySep = layoutChoice mySep' hsep+ where+ -- ensure paragraph fills with indentation.+ mySep' [x] = x+ mySep' (x:xs) = x <+> fsep xs+ mySep' [] = error "Internal error: mySep"++myVcat :: [Doc] -> Doc+myVcat = layoutChoice vcat hsep++myFsepSimple :: [Doc] -> Doc+myFsepSimple = layoutChoice fsep hsep++-- same, except that continuation lines are indented,+-- which is necessary to avoid triggering the offside rule.+myFsep :: [Doc] -> Doc+myFsep = layoutChoice fsep' hsep+ where fsep' [] = empty+ fsep' (d:ds) = do+ e <- getPPEnv+ let n = onsideIndent e+ nest n (fsep (nest (-n) d:ds))++myFsepSCC :: [Doc] -> Doc+myFsepSCC = layoutChoice fsep' hsep+ where fsep' [] = empty+ fsep' (d:ds) = do+ e <- getPPEnv+ let n = onsideIndent e+ nest n (fsep (nest (-n) d:ds))++layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc+layoutChoice a b dl = do e <- getPPEnv+ if layout e == PPOffsideRule ||+ layout e == PPSemiColon+ then a dl else b dl++-- Prefix something with a LINE pragma, if requested.+-- GHC's LINE pragma actually sets the current line number to n-1, so+-- that the following line is line n. But if there's no newline before+-- the line we're talking about, we need to compensate by adding 1.++markLine :: SrcInfo s => s -> Doc -> Doc+markLine loc doc = do+ e <- getPPEnv+ let y = startLine loc+ let line l =+ text ("{-# LINE " ++ show l ++ " \"" ++ fileName loc ++ "\" #-}")+ if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc+ else doc
+ Prof2Html.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleContexts #-}+module Main (main) where+import Language.Haskell.Exts+import Data.Generics.Uniplate.Data+import Control.Monad.State+import Control.Applicative+import Control.Arrow+import qualified Control.Exception as Exc+import qualified Pretty as P+import qualified Language.Haskell.Exts.Pretty as PP+import ParseProfile+import System.Process+import System.Directory+import System.Environment+import System.IO.Error+import Data.Maybe+import GraphUtils+import Data.Char+import qualified Data.IntMap as IMap+import Text.RegexPR+import Debug.Trace+import Numeric+import Data.List+ +type Exp_ = Exp+pprint tm+ = "<style> a.info{ position:relative; z-index:24; color:#000; text-decoration:none} a.info:hover{z-index:25;} a.info span{display: none} a.info:hover span{ /*the span will display just on :hover state*/ display:block; position:absolute; top:2em; left:2em; width:15em; border:1px solid #0cf; background-color:#cff; color:#000; text-align: center} </style><pre>"+ ++ P.prettyPrint 120 tm ++ "</pre>"+ +assignSCC :: Module -> Module+assignSCC m = evalState (transformBiM f m) 0 where+ f e = do st <- get+ put (st + 1)+ return $ addSCC st $ strip e++ strip :: Exp_ -> Exp_+ strip (SCCPragma _ e) = e+ strip e = e++ addSCC :: Int -> Exp_ -> Exp_+ addSCC _ e@(Var _) = e+ addSCC _ e@(Lit _) = e+ addSCC num e = Paren $ SCCPragma (show num) e+ +addColour m s+ = gsubRegexPRBy (pref ++ ".*?" ++ suf)+ (\ str -> pref ++ sccNumToColour str ++ suf)+ s+ where + sccNumToColour :: String -> String+ sccNumToColour str+ = maybe transparentColour toColour $ lookup (readSCCNumber str) m+ + readSCCNumber :: String -> Int+ readSCCNumber str = fst $ head $ reads $ drop (length pref) str+ pref = "color: #"+ suf = "\">"+transparentColour = "00ffffff"+ +toColour :: Float -> String+toColour fl+ | 0 <= fl && fl < 1.0e-2 = transparentColour+ | 1.0e-2 <= fl && fl < yellow =+ (pad $ showHex (truncate $ fl * 255 * (1 / yellow)) "") ++ "ff00"+ | yellow <= fl && fl <= 1 =+ "ff" +++ (pad $+ showHex (255 - (truncate $ (fl - yellow) * 255 / (1 - yellow))) "")+ ++ "00"+ where + pad :: String -> String+ pad str = if length str == 1 then '0':str else str+ yellow = 0.1+ +parseModuleFromFile :: FilePath -> IO Module+parseModuleFromFile path = fromParseResult <$> parseFile path+ +computeTicksMap :: Profile -> [(Int, Float)]+computeTicksMap prof+ = map (\ n -> (read $ nodeName n :: Int, ticksFraction n)) $+ filter (isNumber . head . nodeName) $ IMap.elems graph+ where totalTicks = profileTicks prof+ graph = profileGraph prof+ ticksFraction n+ = (fromInteger $ snd3 $ totalCost $ parentNodes n) /+ (fromInteger totalTicks)+ +computeAllocMap :: Profile -> [(Int, Float)]+computeAllocMap prof+ = allocFraction $+ map (\ n -> (read $ nodeName n :: Int, alloc n)) $+ filter (isNumber . head . nodeName) $ IMap.elems graph+ where graph = profileGraph prof+ + alloc :: Node -> Float+ alloc n = fromInteger $ trd3 $ totalCost $ parentNodes n+ allocFraction l = map (second (/ sumSnd l)) l+ + sumSnd :: [(Int, Float)] -> Float+ sumSnd l = sum $ map snd l+ +snd3 :: (Integer, Integer, Integer) -> Integer+snd3 (_, x, _) = x+ +trd3 :: (Integer, Integer, Integer) -> Integer+trd3 (_, _, x) = x+ind l n = if length l > n then Just $ l !! n else Nothing+ +main :: IO ()+main+ = do args <- getArgs+ let mode = args !! 0+ unless ("-h" `isPrefixOf` mode || "-px" `isPrefixOf` mode)+ (error "mode should be -h or -px")+ let file = args !! 1+ let run = args !! 2+ let programArgs = ind args 3+ let inpFile = ind args 4+ let bak = file ++ ".bak"+ (do removeFile bak `catch`+ (\ e -> if isDoesNotExistError e then return () else ioError e)+ renameFile file bak+ putStrLn "started parsing original file"+ m <- parseModuleFromFile bak+ let tm = assignSCC m+ putStrLn "writing modified file"+ writeFile file $ PP.prettyPrint tm+ let buildStr+ = "ghc -prof -O2 --make " +++ run ++ ".hs && ./" ++ run ++ " +RTS " ++ mode ++ " -RTS"+ let buildStrArgs+ = buildStr ++ " " ++ fromMaybe "" programArgs ++ " "+ let buildStrInp+ = maybe buildStrArgs ((buildStrArgs ++ " < ") ++) inpFile+ putStrLn buildStrInp+ buildCommand <- runCommand buildStrInp+ waitForProcess buildCommand+ (when ("-px" `isPrefixOf` mode) $+ do putStrLn "parsing profiling results"+ profFile <- readFile $ run ++ ".prof"+ let prof = fromJust $ parseProfile (run ++ ".prof") profFile+ let profMap = computeTicksMap prof+ putStrLn "printing output html file"+ let html = addColour profMap $ pprint tm+ writeFile (file ++ ".html") html)+ renameFile file (file ++ ".scc"))+ `Exc.finally`+ (do copyFile bak file+ removeFile bak)
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ visual-prof.cabal view
@@ -0,0 +1,38 @@+Name: visual-prof+Version: 0.1+Cabal-Version: >= 1.2+License: BSD3+License-file: LICENSE+Author: Daniel Velkov+Homepage: http://github.com/djv/VisualProf+Synopsis: Create a visual profile of a program's source code+Description:+ visual-prof profiles your Haskell program and generates a html file containing+ its source code with parts of the code highlighted in different+ colors depending on the fraction of the running time that they take.+ visual-prof gives you an easy way to find places for optimization in your code.+ .+ Usage:+ .+ > visual-prof -px A/B/C.hs run "arg1 arg2"+ .+ This will profile the C.hs file used by run.hs which contains the Main module+ of your project. Arguments to ./run are passed as shown (arg1, arg2,...). The parameters+ should be given in that order.++Maintainer: djvelkov@gmail.com+Category: Development+Build-Type: Simple++Flag splitBase+ description: Choose the new smaller, split-up base package.++Executable visual-prof+ if flag(splitBase)+ Build-Depends: base >= 3 && < 4, containers+ else+ Build-Depends: base < 3+ Build-depends: parsec, filepath, haskell-src-exts, regexpr, directory, process, pretty, mtl, uniplate++ Main-is: Prof2Html.hs+ Other-modules: GraphUtils ParseProfile Pretty