diff --git a/BuildBox/Build/Base.hs b/BuildBox/Build/Base.hs --- a/BuildBox/Build/Base.hs +++ b/BuildBox/Build/Base.hs @@ -8,7 +8,8 @@ import Control.Monad.State import System.IO import System.Directory -import Text.PrettyPrint +import Text.PrettyPrint.Leijen +import Prelude hiding ((<>)) -- | The builder monad encapsulates and IO action that can fail with an error, @@ -39,7 +40,7 @@ = do result <- try $ evalStateT build s case result of Left (err :: BuildError) - -> do putStrLn $ render $ ppr err + -> do putStrLn $ renderIndent $ ppr err return $ Nothing Right x @@ -54,7 +55,7 @@ Left (err :: BuildError) -> do putStrLn "\nBuild failed" putStr " due to " - putStrLn $ render $ ppr err + putStrLn $ renderIndent $ ppr err return $ Nothing Right x @@ -108,12 +109,12 @@ out :: Pretty a => a -> Build () out str = io - $ do putStr $ render $ ppr str + $ do putStr $ renderIndent $ ppr str hFlush stdout -- | Print some text to stdout followed by a newline. outLn :: Pretty a => a -> Build () -outLn str = io $ putStrLn $ render $ ppr str +outLn str = io $ putStrLn $ renderIndent $ ppr str -- | Print a blank line to stdout diff --git a/BuildBox/Build/BuildError.hs b/BuildBox/Build/BuildError.hs --- a/BuildBox/Build/BuildError.hs +++ b/BuildBox/Build/BuildError.hs @@ -7,7 +7,7 @@ import BuildBox.Pretty import Control.Monad.Catch import Data.Typeable -import Text.PrettyPrint +import Text.PrettyPrint.Leijen hiding (Pretty) import System.Exit import BuildBox.Data.Log (Log) import qualified BuildBox.Data.Log as Log @@ -43,7 +43,7 @@ instance Pretty BuildError where - ppr err + pretty err = case err of ErrorOther str -> text "Other error: " <> text str @@ -81,6 +81,6 @@ instance Show BuildError where - show err = render $ ppr err + show err = renderPlain $ ppr err diff --git a/BuildBox/Command/Environment.hs b/BuildBox/Command/Environment.hs --- a/BuildBox/Command/Environment.hs +++ b/BuildBox/Command/Environment.hs @@ -22,8 +22,8 @@ import BuildBox.Command.System import BuildBox.Command.File import BuildBox.Pretty -import Text.PrettyPrint -import Prelude hiding ((<>)) +import Text.PrettyPrint.Leijen +import Prelude hiding ((<>)) -- Environment ------------------------------------------------------------------------------------ @@ -36,13 +36,17 @@ instance Pretty Environment where - ppr env - = hang (ppr "Environment") 2 $ vcat - [ ppr $ environmentPlatform env - , hang (ppr "Versions") 2 - $ vcat - $ map (\(name, ver) -> ppr name <+> ppr ver) - $ environmentVersions env ] + pretty env + = vcat + [ ppr "Environment" + , nest 2 $ vcat + [ ppr $ environmentPlatform env + , nest 2 $ ppr "Versions" + <+> vcat + ( map (\(name, ver) -> ppr name <+> ppr ver) + $ environmentVersions env) + ] + ] @@ -52,12 +56,14 @@ -> Build Environment getEnvironmentWith nameGets - = do platform <- getHostPlatform + = do platform + <- getHostPlatform - versions <- mapM (\(name, get) -> do - ver <- get - return (name, ver)) - $ nameGets + versions + <- mapM (\(name, get) -> do + ver <- get + return (name, ver)) + $ nameGets return $ Environment { environmentPlatform = platform @@ -78,12 +84,15 @@ instance Pretty Platform where - ppr plat - = hang (ppr "Platform") 2 $ vcat - [ ppr "host: " <> (ppr $ platformHostName plat) - , ppr "arch: " <> (ppr $ platformHostArch plat) - , ppr "processor: " <> (ppr $ platformHostProcessor plat) - , ppr "system: " <> (ppr $ platformHostOS plat) <+> (ppr $ platformHostRelease plat) ] + pretty plat + = vcat + [ ppr "Platform" + , nest 2 $ vcat + [ ppr "host: " <> (ppr $ platformHostName plat) + , ppr "arch: " <> (ppr $ platformHostArch plat) + , ppr "processor: " <> (ppr $ platformHostProcessor plat) + , ppr "system: " <> (ppr $ platformHostOS plat) + <+> (ppr $ platformHostRelease plat) ]] -- | Get information about the host platform. diff --git a/BuildBox/Command/File.hs b/BuildBox/Command/File.hs --- a/BuildBox/Command/File.hs +++ b/BuildBox/Command/File.hs @@ -12,7 +12,6 @@ where import BuildBox.Build import System.Directory --- import Control.Exception import Control.Monad.State import Control.Monad.Catch import System.Info @@ -112,9 +111,9 @@ -- File name template. let sTemplate = "buildbox-" ++ show buildSeq ++ ".tmp" - System.withTempFile + System.withTempFile buildDir sTemplate - (\ fileName h + (\ fileName h -> do io $ System.hClose h build fileName) @@ -137,10 +136,10 @@ io $ writeFile tmp str e <- io $ try $ renameFile tmp filePath - -- renameFile may not be able to rename files across physical devices, + -- renameFile may not be able to rename files across physical devices, -- depending on the implementation. If renameFile fails then try copyFile. case (e :: Either SomeException ()) of - Right _ + Right _ -> return () Left _ diff --git a/BuildBox/Command/Mail.hs b/BuildBox/Command/Mail.hs --- a/BuildBox/Command/Mail.hs +++ b/BuildBox/Command/Mail.hs @@ -18,7 +18,7 @@ import Data.Time.LocalTime import Data.Time.Format import Data.Time.Calendar -import Text.PrettyPrint +import Text.PrettyPrint.Leijen import Prelude hiding ((<>)) @@ -112,15 +112,12 @@ -> ssystemTee False (mailerPath mailer ++ " -t ") -- read recipients from the mail - (render $ renderMail mail) + (renderIndent $ renderMail mail) MailerMSMTP{} -> ssystemTee False (mailerPath mailer ++ " -t " -- read recipients from the mail ++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer)) - (render $ renderMail mail) - - - + (renderIndent $ renderMail mail) diff --git a/BuildBox/Data/Comparison.hs b/BuildBox/Data/Comparison.hs --- a/BuildBox/Data/Comparison.hs +++ b/BuildBox/Data/Comparison.hs @@ -6,7 +6,8 @@ where import BuildBox.Pretty import Text.Printf -import Text.PrettyPrint +import Text.PrettyPrint.Leijen +import Prelude hiding ((<>)) -- | The comparison of two values. @@ -24,17 +25,17 @@ deriving (Read, Show) instance Pretty a => Pretty (Comparison a) where - ppr (Comparison _ recent ratio) + pretty (Comparison _ recent ratio) | abs ratio < 0.01 = text $ printf "%s (----)" - (render $ ppr recent) + (renderPlain $ ppr recent) | otherwise = text $ printf "%s (%+4.0f)" - (render $ ppr recent) + (renderPlain $ ppr recent) (ratio * 100) - ppr (ComparisonNew new) + pretty (ComparisonNew new) = (padL 10 $ ppr new) diff --git a/BuildBox/Data/Detail.hs b/BuildBox/Data/Detail.hs --- a/BuildBox/Data/Detail.hs +++ b/BuildBox/Data/Detail.hs @@ -7,8 +7,9 @@ , Sized (..)) where import BuildBox.Pretty -import Text.PrettyPrint +import Text.PrettyPrint.Leijen + data Detail = DetailTimed Timed | DetailUsed Used @@ -27,7 +28,7 @@ deriving (Eq, Ord, Show, Read, Enum) instance Pretty Timed where - ppr timed + pretty timed = case timed of TotalWall -> text "runtime (wall clock)" TotalCpu -> text "runtime (cpu usage)" @@ -45,7 +46,7 @@ deriving (Eq, Ord, Show, Read, Enum) instance Pretty Used where - ppr used + pretty used = case used of HeapMax -> text "maximum heap usage" HeapAlloc -> text "heap allocation" @@ -57,7 +58,7 @@ deriving (Eq, Ord, Show, Read, Enum) instance Pretty Sized where - ppr sized + pretty sized = case sized of ExeSize -> text "executable size" diff --git a/BuildBox/Data/Physical.hs b/BuildBox/Data/Physical.hs --- a/BuildBox/Data/Physical.hs +++ b/BuildBox/Data/Physical.hs @@ -6,7 +6,8 @@ import BuildBox.Data.Dividable import BuildBox.Pretty import Data.Maybe -import Text.PrettyPrint +import Text.PrettyPrint.Leijen +import Prelude hiding ((<>)) -- | Seconds of time, pretty printed in engineering format. @@ -28,7 +29,7 @@ fromInteger i = Seconds (fromInteger i) instance Pretty Seconds where - ppr (Seconds f) + pretty (Seconds f) = fromMaybe (text (show f)) $ pprEngDouble "s" f @@ -52,6 +53,6 @@ fromInteger i = Bytes (fromInteger i) instance Pretty Bytes where - ppr (Bytes b) + pretty (Bytes b) = fromMaybe (text (show b)) $ pprEngInteger "B" b diff --git a/BuildBox/Data/Range.hs b/BuildBox/Data/Range.hs --- a/BuildBox/Data/Range.hs +++ b/BuildBox/Data/Range.hs @@ -6,7 +6,8 @@ where import BuildBox.Pretty import BuildBox.Data.Dividable -import Text.PrettyPrint +import Text.PrettyPrint.Leijen +import Prelude hiding ((<>)) -- | A range extracted from many-valued data. data Range a @@ -17,7 +18,7 @@ deriving (Read, Show) instance Pretty a => Pretty (Range a) where - ppr (Range mi av mx) + pretty (Range mi av mx) = (ppr mi) <+> text "/" <+> (ppr av) <+> text "/" <+> (ppr mx) diff --git a/BuildBox/Pretty.hs b/BuildBox/Pretty.hs --- a/BuildBox/Pretty.hs +++ b/BuildBox/Pretty.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, - IncoherentInstances #-} - +{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Pretty printing utils. module BuildBox.Pretty ( Pretty(..) @@ -8,47 +7,46 @@ , padLc, padL , blank , pprEngDouble - , pprEngInteger) + , pprEngInteger + , renderIndent + , renderPlain + , ppr) where -import Text.PrettyPrint import Text.Printf +import Text.PrettyPrint.Leijen import Data.Time import Control.Monad import Prelude hiding ((<>)) --- Things that can be pretty printed -class Pretty a where - ppr :: a -> Doc - -- Basic instances -instance Pretty Doc where - ppr = id +instance Pretty UTCTime where + pretty = text . show -instance Pretty Float where - ppr = text . show +instance Pretty String where + pretty = text -instance Pretty Int where - ppr = int -instance Pretty Integer where - ppr = text . show +ppr :: Pretty a => a -> Doc +ppr = pretty -instance Pretty UTCTime where - ppr = text . show -instance Pretty a => Pretty [a] where - ppr xx - = lbrack <> (hcat $ punctuate (text ", ") (map ppr xx)) <> rbrack +-- | Render a thing as a string. +renderIndent :: Pretty a => a -> String +renderIndent x + = displayS (renderPretty 0.4 80 (pretty x)) "" -instance Pretty String where - ppr = text +-- | Render a thing with no indenting. +renderPlain :: Pretty a => a -> String +renderPlain x + = displayS (renderCompact (pretty x)) "" + -- | Right justify a doc, padding with a given character. padRc :: Int -> Char -> Doc -> Doc padRc n c str - = (text $ replicate (n - length (render str)) c) <> str + = (text $ replicate (n - length (renderPlain str)) c) <> str -- | Right justify a string with spaces. @@ -59,16 +57,17 @@ -- | Left justify a string, padding with a given character. padLc :: Int -> Char -> Doc -> Doc padLc n c str - = str <> (text $ replicate (n - length (render str)) c) + = str <> (text $ replicate (n - length (displayS (renderPretty 0.4 80 str) "")) c) -- | Left justify a string with spaces. padL :: Int -> Doc -> Doc padL n str = padLc n ' ' str --- | Blank text. This is different different from `empty` because it comes out a a newline when used in a `vcat`. +-- | Blank text. This is different different from `empty` because it comes out a a +-- newline when used in a `vcat`. blank :: Doc -blank = ppr "" +blank = pretty "" -- | Like `pprEngDouble` but don't display fractional part when the value is < 1000. diff --git a/buildbox.cabal b/buildbox.cabal --- a/buildbox.cabal +++ b/buildbox.cabal @@ -1,5 +1,5 @@ Name: buildbox -Version: 2.1.10.1 +Version: 2.1.11.1 License: BSD3 License-file: LICENSE Author: Ben Lippmeier @@ -31,7 +31,7 @@ process >= 1.2 && < 1.7, temporary >= 1.2 && < 1.4, exceptions >= 0.8 && < 0.11, - pretty >= 1.1 && < 1.2, + wl-pprint >= 1.1 && < 1.3, stm >= 2.4 && < 2.5, text >= 1.2 && < 1.3