module UHC.Util.Pretty
(
module UHC.Util.PrettySimple
, PP_DocL
, ppListSep, ppListSepV, ppListSepVV
, ppBlock, ppBlock'
, ppCommas, ppCommas'
, ppSemis, ppSemis'
, ppSpaces
, ppCurlys
, ppCurlysBlock
, ppCurlysSemisBlock
, ppCurlysCommasBlock
, ppCurlysCommas, ppCurlysCommas', ppCurlysCommasWith
, ppCurlysSemis, ppCurlysSemis'
, ppParensCommas, ppParensCommas'
, ppParensSemisBlock
, ppParensCommasBlock
, ppBrackets
, ppBracketsCommas, ppBracketsCommas', ppBracketsCommasV
, ppHorizontally, ppVertically
, ppListSepFill
, ppPacked, ppParens, ppCurly, ppVBar
, ppDots, ppMb, ppUnless, ppWhen
, hPutWidthPPLn, putWidthPPLn
, hPutPPLn, putPPLn
, hPutPPFile, putPPFile
, putPPFPath
)
where
import UHC.Util.PrettySimple
import UHC.Util.FPath
import System.IO
import Data.List
type PP_DocL = [PP_Doc]
ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c
ppListSepWith :: (PP s, PP c, PP o) => o -> c -> s -> (a->PP_Doc) -> [a] -> PP_Doc
ppListSepWith o c s ppa pps = o >|< hlist (intersperse (pp s) (map ppa pps)) >|< c
ppBlock' :: (PP ocs,PP a) => ocs -> ocs -> ocs -> [a] -> [PP_Doc]
ppBlock' o c s [] = [o >|< c]
ppBlock' o c s [a] = [o >|< a >|< c]
ppBlock' o c s (a:as) = [o >|< a] ++ map (s >|<) as ++ [pp c]
ppBlock :: (PP ocs,PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc
ppBlock o c s = vlist . ppBlock' o c s
ppCommas :: PP a => [a] -> PP_Doc
ppCommas = ppListSep "" "" ","
ppCommas' :: PP a => [a] -> PP_Doc
ppCommas' = ppListSep "" "" ", "
ppSemis :: PP a => [a] -> PP_Doc
ppSemis = ppListSep "" "" ";"
ppSemis' :: PP a => [a] -> PP_Doc
ppSemis' = ppListSep "" "" "; "
ppSpaces :: PP a => [a] -> PP_Doc
ppSpaces = ppListSep "" "" " "
ppCurlysBlock :: PP a => [a] -> PP_Doc
ppCurlysBlock = ppBlock "{ " "}" " " . map pp
ppCurlysSemisBlock :: PP a => [a] -> PP_Doc
ppCurlysSemisBlock = ppBlock "{ " "}" "; " . map pp
ppCurlysCommasBlock :: PP a => [a] -> PP_Doc
ppCurlysCommasBlock = ppBlock "{ " "}" ", " . map pp
ppParensSemisBlock :: PP a => [a] -> PP_Doc
ppParensSemisBlock = ppBlock "( " ")" "; " . map pp
ppParensCommasBlock :: PP a => [a] -> PP_Doc
ppParensCommasBlock = ppBlock "( " ")" ", " . map pp
ppBracketsCommas :: PP a => [a] -> PP_Doc
ppBracketsCommas = ppListSep "[" "]" ","
ppBracketsCommasV :: PP a => [a] -> PP_Doc
ppBracketsCommasV = ppListSepV3 "[ " "]" ", "
ppBracketsCommas' :: PP a => [a] -> PP_Doc
ppBracketsCommas' = ppListSep "[" "]" ", "
ppParensCommas :: PP a => [a] -> PP_Doc
ppParensCommas = ppListSep "(" ")" ","
ppParensCommas' :: PP a => [a] -> PP_Doc
ppParensCommas' = ppListSep "(" ")" ", "
ppCurlysCommas :: PP a => [a] -> PP_Doc
ppCurlysCommas = ppListSep "{" "}" ","
ppCurlysCommasWith :: PP a => (a->PP_Doc) -> [a] -> PP_Doc
ppCurlysCommasWith = ppListSepWith "{" "}" ","
ppCurlysCommas' :: PP a => [a] -> PP_Doc
ppCurlysCommas' = ppListSep "{" "}" ", "
ppCurlysSemis :: PP a => [a] -> PP_Doc
ppCurlysSemis = ppListSep "{" "}" ";"
ppCurlysSemis' :: PP a => [a] -> PP_Doc
ppCurlysSemis' = ppListSep "{" "}" "; "
ppListSepV' :: (PP s, PP c, PP o, PP a) => (forall x y . (PP x, PP y) => x -> y -> PP_Doc) -> o -> c -> s -> [a] -> PP_Doc
ppListSepV' aside o c s pps
= l pps
where l [] = o `aside` c
l [p] = o `aside` p `aside` c
l (p:ps) = vlist ([o `aside` p] ++ map (s `aside`) (init ps) ++ [s `aside` last ps `aside` c])
ppListSepV3 :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
ppListSepV3 o c s pps
= l pps
where l [] = o >|< c
l [p] = o >|< p >|< c
l (p:ps) = vlist ([o >|< p] ++ map (s >|<) (init ps) ++ [s >|< last ps >|< c])
ppListSepV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
ppListSepV = ppListSepV' (>|<)
ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
ppListSepVV = ppListSepV' (>-<)
ppVertically :: [PP_Doc] -> PP_Doc
ppVertically = vlist
ppHorizontally :: [PP_Doc] -> PP_Doc
ppHorizontally = hlist
ppListSepFill :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
ppListSepFill o c s pps
= l pps
where l [] = o >|< c
l [p] = o >|< pp p >|< c
l (p:ps) = fill ((o >|< pp p) : map (s >|<) ps) >|< c
ppPacked :: (PP o, PP c, PP p) => o -> c -> p -> PP_Doc
ppPacked o c pp
= o >|< pp >|< c
ppParens, ppBrackets, ppCurly, ppCurlys, ppVBar :: PP p => p -> PP_Doc
ppParens = ppPacked "(" ")"
ppBrackets = ppPacked "[" "]"
ppCurly = ppPacked "{" "}"
ppCurlys = ppCurly
ppVBar = ppPacked "|" "| "
ppDots :: PP a => [a] -> PP_Doc
ppDots = ppListSep "" "" "."
ppMb :: PP a => Maybe a -> PP_Doc
ppMb = maybe empty pp
ppUnless :: Bool -> PP_Doc -> PP_Doc
ppUnless b p = if b then empty else p
ppWhen :: Bool -> PP_Doc -> PP_Doc
ppWhen b p = if b then p else empty
instance PP a => PP (Maybe a) where
pp = maybe (pp "?") pp
instance PP Bool where
pp = pp . show
hPutLn :: Handle -> Int -> PP_Doc -> IO ()
hPutLn h w pp
= hPutStrLn h (disp pp w "")
hPutWidthPPLn :: Handle -> Int -> PP_Doc -> IO ()
hPutWidthPPLn h w pp = hPutLn h w pp
putWidthPPLn :: Int -> PP_Doc -> IO ()
putWidthPPLn = hPutWidthPPLn stdout
hPutPPLn :: Handle -> PP_Doc -> IO ()
hPutPPLn h = hPutWidthPPLn h 4000
putPPLn :: PP_Doc -> IO ()
putPPLn = hPutPPLn stdout
hPutPPFile :: Handle -> PP_Doc -> Int -> IO ()
hPutPPFile h pp wid
= hPutLn h wid pp
putPPFPath :: FPath -> PP_Doc -> Int -> IO ()
putPPFPath fp pp wid
= do { fpathEnsureExists fp
; putPPFile (fpathToStr fp) pp wid
}
putPPFile :: String -> PP_Doc -> Int -> IO ()
putPPFile fn pp wid
= do { h <- openFile fn WriteMode
; hPutPPFile h pp wid
; hClose h
}