diff --git a/GraphUtils.hs b/GraphUtils.hs new file mode 100644 --- /dev/null +++ b/GraphUtils.hs @@ -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 } + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/ParseProfile.hs b/ParseProfile.hs new file mode 100644 --- /dev/null +++ b/ParseProfile.hs @@ -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: +-- +-- +-- +-- The second line is a quoted string giving the sampling interval, e.g., +-- "20 ms": +-- +-- +-- +-- 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 +-- +-- The is a integer, the and +-- are quoted strings. +-- +-- The call tree itself is given by lines beginning with a literal '2'. +-- Each line looks like: +-- +-- 2 +-- +-- The is identifies the stack to which this +-- belongs. The is a literal '1' if this +-- cost center is the root of the call tree, a literal '2' otherwise. +-- The is the cost center stack code of the parent of this +-- cost center. If the is '1' the field is +-- absent. The , and +-- are all integers. +-- +-- One important thing to note is that multiple lines can have the same +-- . Only the first entry contains cost accounting +-- data. The other lines with the same 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 {1 }+ 0 +-- +-- where the expression in curly braces is repeated for all of the +-- cost center stack codes. Each cost reports for +-- begins with a literal '1'. The and the +-- , and 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 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 . 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 diff --git a/Pretty.hs b/Pretty.hs new file mode 100644 --- /dev/null +++ b/Pretty.hs @@ -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 "" <> zeroWidthText s <> zeroWidthText " zeroWidthText s <> zeroWidthText "\">" <> pretty e <> zeroWidthText "" + 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 diff --git a/Prof2Html.hs b/Prof2Html.hs new file mode 100644 --- /dev/null +++ b/Prof2Html.hs @@ -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 + = "
"
+      ++ P.prettyPrint 120 tm ++ "
" + +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) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/visual-prof.cabal b/visual-prof.cabal new file mode 100644 --- /dev/null +++ b/visual-prof.cabal @@ -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