chr-pretty (empty) → 0.1.0.0
raw patch · 6 files changed
+821/−0 lines, 6 filesdep +basedep +containerssetup-changed
Dependencies added: base, containers
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- chr-pretty.cabal +34/−0
- src/CHR/Pretty.hs +520/−0
- src/CHR/Pretty/Simple.hs +230/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for chr-pretty++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Atze Dijkstra++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Atze Dijkstra nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chr-pretty.cabal view
@@ -0,0 +1,34 @@+-- Initial chr-pretty.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: chr-pretty+version: 0.1.0.0+synopsis: Pretty printing for chr library+description: Pretty printing for chr library, a simplified implementation for the pretty printing API from uulib+homepage: https://github.com/atzedijkstra/chr+Bug-Reports: https://github.com/atzedijkstra/chr/issues+license: BSD3+license-file: LICENSE+author: Atze Dijkstra+maintainer: atzedijkstra@gmail.com+-- copyright: +category: Development+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git@github.com:atzedijkstra/chr.git++library+ exposed-modules:+ CHR.Pretty+ other-modules:+ CHR.Pretty.Simple+ -- other-extensions: + build-depends:+ base >=4.9 && < 5,+ containers >= 0.4+ hs-source-dirs: src+ default-language: Haskell2010
+ src/CHR/Pretty.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE RankNTypes, TypeSynonymInstances #-}++-------------------------------------------------------------------------+-- Wrapper module around pretty printing+-------------------------------------------------------------------------++module CHR.Pretty+ ( -- module UU.Pretty+ -- module UHC.Util.Chitil.Pretty+ module CHR.Pretty.Simple++ , PP_DocL++ -- * Choice combinators+ , (>-|-<)+ , (>-#-<)+ + -- * General PP for list+ , ppListSep, ppListSepV, ppListSepVV+ + -- * Pack PP around+ , ppCurlys+ , ppPacked+ , ppPackedWithStrings+ , ppParens+ , ppCurly+ , ppBrackets+ , ppVBar+ + -- * Block, horizontal/vertical as required+ , ppBlock, ppBlockH+ , ppBlock'+ , ppBlockWithStrings+ , ppBlockWithStrings'+ , ppBlockWithStringsH+ + , ppParensCommasBlock+ , ppCurlysBlock+ , ppCurlysSemisBlock+ , ppCurlysCommasBlock+ , ppParensSemisBlock+ , ppBracketsCommasBlock+ + , ppParensCommasBlockH+ , ppCurlysBlockH+ , ppCurlysSemisBlockH+ , ppCurlysCommasBlockH+ , ppParensSemisBlockH+ , ppBracketsCommasBlockH+ + , ppBracketsCommasV+ + -- * Vertical PP of list only+ , ppVertically+ + -- * Horizontal PP of list only+ , ppCommas, ppCommas'+ , ppSemis, ppSemis'+ , ppSpaces+ , ppCurlysCommas, ppCurlysCommas', ppCurlysCommasWith+ , ppCurlysSemis, ppCurlysSemis'+ , ppParensSpaces+ , ppParensCommas, ppParensCommas'+ , ppBracketsCommas+ , ppBracketsCommas'+ , ppHorizontally+ , ppListSepFill++ -- * Conditional+ , ppMbPre, ppMbPost+ , ppListPre, ppListPost++ -- * Misc+ , ppDots, ppMb, ppUnless, ppWhen++ -- * Render+ , showPP+ + -- * IO+ , hPutWidthPPLn, putWidthPPLn+ , hPutPPLn, putPPLn+ , hPutPPFile, putPPFile+ -- , putPPFPath+ )+ where++-- import UU.Pretty+-- import UHC.Util.Chitil.Pretty+import CHR.Pretty.Simple+-- import CHR.Utils+-- import UHC.Util.FPath+-- import UHC.Util.Time+import System.IO+import Data.List+import Data.Word+import qualified Data.Set as Set++-------------------------------------------------------------------------+-- PP utils for lists+-------------------------------------------------------------------------++type PP_DocL = [PP_Doc]++-- | PP list with open, separator, and close+ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSep = ppListSepWith pp -- o >|< hlist (intersperse (pp s) (map pp pps)) >|< c+{-+ppListSep o c s pps+ = o >|< l pps >|< c+ where l [] = empty+ l [p] = pp p+ l (p:ps) = pp p >|< map (s >|<) ps+-}++-- | PP list with open, separator, and close, and explicit PP function+ppListSepWith :: (PP s, PP c, PP o) => (a->PP_Doc) -> o -> c -> s -> [a] -> PP_Doc+ppListSepWith ppa o c s pps = o >|< hlist (intersperse (pp s) (map ppa pps)) >|< c++{-# DEPRECATED ppListSepFill "Use ppListSep" #-}+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) = hlist ((o >|< pp p) : map (s >|<) ps) >|< c++-- | PP in a blocklike fashion, possibly on a single horizontal line if indicated, yielding the lines of the block+ppBlock'' :: (PP ocs, PP a) => Bool -> ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]+ppBlock'' _ osngl _ c _ [] = [osngl >|< c]+ppBlock'' _ osngl o c _ [a] | isSingleLine x = [osngl >|< x >|< c]+ | otherwise = [o >|< x] ++ [pp c]+ where x = pp a+ppBlock'' hori osngl o c s aa@(a:as) -- = [o >|< a] ++ map (s >|<) as ++ [pp c]+ | hori && all isSingleLine xx = [osngl >|< x >|< hlist (map (s >|<) xs) >|< c]+ | otherwise = [o >|< x] ++ map (s >|<) xs ++ [pp c]+ where xx@(x:xs) = map pp aa++-- | PP in a blocklike fashion, vertically+ppBlock' :: (PP ocs, PP a) => ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]+ppBlock' = ppBlock'' False+{-# INLINE ppBlock' #-}++-- | PP in a blocklike fashion, vertically, possibly horizontally+ppBlockH' :: (PP ocs, PP a) => ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc]+ppBlockH' = ppBlock'' True+{-# INLINE ppBlockH' #-}++-- | PP list with open, separator, and close in a possibly multiline block structure+ppBlock :: (PP ocs, PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc+ppBlock o c s = vlist . ppBlock' o o c s++-- | PP list with open, separator, and close in a possibly multiline block structure+ppBlockH :: (PP ocs, PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc+ppBlockH o c s = vlist . ppBlockH' o o c s++-- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements+ppBlockWithStrings'' :: (PP a) => Bool -> String -> String -> String -> [a] -> [PP_Doc]+ppBlockWithStrings'' hori o c s = ppBlock'' hori o (pad o) c (pad s)+ where l = maximum $ map length [o,s]+ pad s = s ++ replicate (l - length s) ' '++-- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements+ppBlockWithStrings' :: (PP a) => String -> String -> String -> [a] -> [PP_Doc]+ppBlockWithStrings' = ppBlockWithStrings'' False+{-# INLINE ppBlockWithStrings' #-}++-- | See 'ppBlock', but with string delimiters aligned properly, yielding a list of elements, preferring single line horizontal placement+ppBlockWithStringsH' :: (PP a) => String -> String -> String -> [a] -> [PP_Doc]+ppBlockWithStringsH' = ppBlockWithStrings'' True+{-# INLINE ppBlockWithStringsH' #-}++-- | See 'ppBlock', but with string delimiters aligned properly+ppBlockWithStrings :: (PP a) => String -> String -> String -> [a] -> PP_Doc+ppBlockWithStrings o c s = vlist . ppBlockWithStrings' o c s++-- | See 'ppBlock', but with string delimiters aligned properly, preferring single line horizontal placement+ppBlockWithStringsH :: (PP a) => String -> String -> String -> [a] -> PP_Doc+ppBlockWithStringsH o c s = vlist . ppBlockWithStringsH' o c s++-- | PP horizontally: list separated by comma+ppCommas :: PP a => [a] -> PP_Doc+ppCommas = ppListSep "" "" ","++-- | PP horizontally: list separated by comma + single blank+ppCommas' :: PP a => [a] -> PP_Doc+ppCommas' = ppListSep "" "" ", "++-- | PP horizontally: list separated by semicolon+ppSemis :: PP a => [a] -> PP_Doc+ppSemis = ppListSep "" "" ";"++-- | PP horizontally: list separated by semicolon + single blank+ppSemis' :: PP a => [a] -> PP_Doc+ppSemis' = ppListSep "" "" "; "++-- | PP horizontally: list separated by single blank+ppSpaces :: PP a => [a] -> PP_Doc+ppSpaces = ppListSep "" "" " "++-- | PP horizontally or vertically with "{", " ", and "}" in a possibly multiline block structure+ppCurlysBlock :: PP a => [a] -> PP_Doc+ppCurlysBlock = ppBlockWithStrings "{" "}" " "+{-# INLINE ppCurlysBlock #-}++-- | PP horizontally or vertically with "{", " ", and "}" in a possibly multiline block structure, preferring single line horizontal placement+ppCurlysBlockH :: PP a => [a] -> PP_Doc+ppCurlysBlockH = ppBlockWithStringsH "{" "}" " "+{-# INLINE ppCurlysBlockH #-}++-- | PP horizontally or vertically with "{", ";", and "}" in a possibly multiline block structure+ppCurlysSemisBlock :: PP a => [a] -> PP_Doc+ppCurlysSemisBlock = ppBlockWithStrings "{" "}" "; "+{-# INLINE ppCurlysSemisBlock #-}++-- | PP horizontally or vertically with "{", ";", and "}" in a possibly multiline block structure, preferring single line horizontal placement+ppCurlysSemisBlockH :: PP a => [a] -> PP_Doc+ppCurlysSemisBlockH = ppBlockWithStringsH "{" "}" "; "+{-# INLINE ppCurlysSemisBlockH #-}++-- | PP horizontally or vertically with "{", ",", and "}" in a possibly multiline block structure+ppCurlysCommasBlock :: PP a => [a] -> PP_Doc+ppCurlysCommasBlock = ppBlockWithStrings "{" "}" ", "+{-# INLINE ppCurlysCommasBlock #-}++-- | PP horizontally or vertically with "{", ",", and "}" in a possibly multiline block structure, preferring single line horizontal placement+ppCurlysCommasBlockH :: PP a => [a] -> PP_Doc+ppCurlysCommasBlockH = ppBlockWithStringsH "{" "}" ", "+{-# INLINE ppCurlysCommasBlockH #-}++-- | PP horizontally or vertically with "(", ";", and ")" in a possibly multiline block structure+ppParensSemisBlock :: PP a => [a] -> PP_Doc+ppParensSemisBlock = ppBlockWithStrings "(" ")" "; "+{-# INLINE ppParensSemisBlock #-}++-- | PP horizontally or vertically with "(", ";", and ")" in a possibly multiline block structure, preferring single line horizontal placement+ppParensSemisBlockH :: PP a => [a] -> PP_Doc+ppParensSemisBlockH = ppBlockWithStringsH "(" ")" "; "+{-# INLINE ppParensSemisBlockH #-}++-- | PP horizontally or vertically with "(", ",", and ")" in a possibly multiline block structure+ppParensCommasBlock :: PP a => [a] -> PP_Doc+ppParensCommasBlock = ppBlockWithStrings "(" ")" ", "+{-# INLINE ppParensCommasBlock #-}++-- | PP horizontally or vertically with "(", ",", and ")" in a possibly multiline block structure, preferring single line horizontal placement+ppParensCommasBlockH :: PP a => [a] -> PP_Doc+ppParensCommasBlockH = ppBlockWithStringsH "(" ")" ", "+{-# INLINE ppParensCommasBlockH #-}++-- | PP horizontally or vertically with "[", ",", and "]" in a possibly multiline block structure+ppBracketsCommasV, ppBracketsCommasBlock, ppBracketsCommasBlockH :: PP a => [a] -> PP_Doc+ppBracketsCommasBlock = ppBlockWithStrings "[" "]" ", "+{-# INLINE ppBracketsCommasBlock #-}+ppBracketsCommasBlockH = ppBlockWithStringsH "[" "]" ", "+{-# INLINE ppBracketsCommasBlockH #-}+ppBracketsCommasV = ppBracketsCommasBlock+{-# DEPRECATED ppBracketsCommasV "Use ppBracketsCommasBlock" #-}++-- | PP horizontally with "[", ",", and "]"+ppBracketsCommas :: PP a => [a] -> PP_Doc+ppBracketsCommas = ppListSep "[" "]" ","++-- | PP horizontally with "[", ", ", and "]"+ppBracketsCommas' :: PP a => [a] -> PP_Doc+ppBracketsCommas' = ppListSep "[" "]" ", "++-- | PP horizontally with "(", " ", and ")"+ppParensSpaces :: PP a => [a] -> PP_Doc+ppParensSpaces = ppListSep "(" ")" " "++-- | PP horizontally with "(", ",", and ")"+ppParensCommas :: PP a => [a] -> PP_Doc+ppParensCommas = ppListSep "(" ")" ","++-- | PP horizontally with "(", ", ", and ")"+ppParensCommas' :: PP a => [a] -> PP_Doc+ppParensCommas' = ppListSep "(" ")" ", "++-- | PP horizontally with "{", ",", and "}"+ppCurlysCommas :: PP a => [a] -> PP_Doc+ppCurlysCommas = ppListSep "{" "}" ","++ppCurlysCommasWith :: PP a => (a->PP_Doc) -> [a] -> PP_Doc+ppCurlysCommasWith ppa = ppListSepWith ppa "{" "}" ","++-- | PP horizontally with "{", ", ", and "}"+ppCurlysCommas' :: PP a => [a] -> PP_Doc+ppCurlysCommas' = ppListSep "{" "}" ", "++-- | PP horizontally with "{", ";", and "}"+ppCurlysSemis :: PP a => [a] -> PP_Doc+ppCurlysSemis = ppListSep "{" "}" ";"++-- | PP horizontally with "{", "; ", and "}"+ppCurlysSemis' :: PP a => [a] -> PP_Doc+ppCurlysSemis' = ppListSep "{" "}" "; "++{-+ppCommaListV :: PP a => [a] -> PP_Doc+ppCommaListV = ppListSepVV "[" "]" "; "+-}++{-# DEPRECATED ppListSepV', ppListSepV, ppListSepVV "Use pp...Block variants" #-}+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])++-- compact vertical list+{-+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' (>-<)++-- | Alias for 'vlist'+ppVertically :: [PP_Doc] -> PP_Doc+ppVertically = vlist++-- | Alias for 'hlist'+ppHorizontally :: [PP_Doc] -> PP_Doc+ppHorizontally = hlist++-------------------------------------------------------------------------+-- Printing open/close pairs+-------------------------------------------------------------------------++ppPacked :: (PP o, PP c, PP p) => o -> c -> p -> PP_Doc+ppPacked o c pp+ = o >|< pp >|< c++ppPackedWithStrings :: (PP p) => String -> String -> p -> PP_Doc+ppPackedWithStrings o c x = ppBlockWithStrings o c "" [x]++ppParens, ppBrackets, ppCurly, ppCurlys, ppVBar :: PP p => p -> PP_Doc+ppParens = ppPackedWithStrings "(" ")"+ppBrackets = ppPackedWithStrings "[" "]"+ppCurly = ppPackedWithStrings "{" "}"+ppCurlys = ppCurly+ppVBar = ppPackedWithStrings "|" "|"++-------------------------------------------------------------------------+-- Additional choice combinators, use with care...+-------------------------------------------------------------------------++infixr 2 >-|-<, >-#-<++aside :: (PP a, PP b) => String -> a -> b -> PP_Doc+aside sep l r | isSingleLine l' && isSingleLine r' = l' >|< sep >|< r'+ | otherwise = l' >-< sep >|< r'+ where l' = pp l+ r' = pp r++-- | As (>|<), but doing (>-<) when does not fit on single line+(>-|-<) :: (PP a, PP b) => a -> b -> PP_Doc+(>-|-<) = aside ""++-- | As (>#<), but doing (>-<) when does not fit on single line+(>-#-<) :: (PP a, PP b) => a -> b -> PP_Doc+(>-#-<) = aside " "++-------------------------------------------------------------------------+-- Conditional+-------------------------------------------------------------------------++maybeNull :: r -> ([a] -> r) -> [a] -> r+maybeNull n f l = if null l then n else f l+{-# INLINE maybeNull #-}++-- | Only prefix with a 'Maybe' and extra space when 'Just'+ppMbPre :: (PP x, PP r) => (a -> x) -> Maybe a -> r -> PP_Doc+ppMbPre p = maybe pp (\v rest -> p v >#< rest)++-- | Only suffix with a 'Maybe' and extra space when 'Just'+ppMbPost :: (PP x, PP r) => (a -> x) -> Maybe a -> r -> PP_Doc+ppMbPost p = maybe pp (\v rest -> rest >#< p v)++-- | Only prefix with a list and extra space when non-empty+ppListPre :: (PP x, PP r) => ([a] -> x) -> [a] -> r -> PP_Doc+ppListPre p = maybeNull pp (\l rest -> p l >#< rest)++-- | Only suffix with a list and extra space when non-empty+ppListPost :: (PP x, PP r) => ([a] -> x) -> [a] -> r -> PP_Doc+ppListPost p = maybeNull pp (\l rest -> p l >#< rest)++-- | Guard around PP: if False pass through+ppUnless :: PP x => Bool -> x -> PP_Doc+ppUnless b x = if b then empty else pp x++-- | Guard around PP: if True pass through+ppWhen :: PP x => Bool -> x -> PP_Doc+ppWhen b x = if b then pp x else empty++-------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------++ppDots :: PP a => [a] -> PP_Doc+ppDots = ppListSep "" "" "."++ppMb :: PP a => Maybe a -> PP_Doc+ppMb = maybe empty pp++-------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------++instance {-# OVERLAPPABLE #-} PP a => PP (Maybe a) where+ pp = maybe (pp "?") pp++instance {-# OVERLAPPABLE #-} PP a => PP (Set.Set a) where+ pp = ppCurlysCommasBlockH . Set.toList++instance PP Bool where+ pp = pp . show++instance PP Word32 where+ pp = pp . show++{-+instance PP ClockTime where+ pp = pp . show++instance PP FPath where+ pp = pp . fpathToStr+-}++instance PP () where+ pp _ = pp "()"++instance (PP a, PP b) => PP (a,b) where+ pp (a,b) = "(" >|< a >-|-< "," >|< b >-|-< ")"++instance (PP a, PP b, PP c) => PP (a,b,c) where+ pp (a,b,c) = "(" >|< a >-|-< "," >|< b >-|-< "," >|< c >-|-< ")"++{-+instance (PP a, PP b, PP c, PP d) => PP (a,b,c,d) where+ pp (a,b,c,d) = ppParensCommasBlock [a,b,c,d]++instance (PP a, PP b, PP c, PP d, PP e) => PP (a,b,c,d,e) where+ pp (a,b,c,d,e) = ppParensCommasBlock [a,b,c,d,e]++instance (PP a, PP b, PP c, PP d, PP e, PP f) => PP (a,b,c,d,e,f) where+ pp (a,b,c,d,e,f) = ppParensCommasBlock [a,b,c,d,e,f]++instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g) => PP (a,b,c,d,e,f,g) where+ pp (a,b,c,d,e,f,g) = ppParensCommasBlock [a,b,c,d,e,f,g]++instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h) => PP (a,b,c,d,e,f,g,h) where+ pp (a,b,c,d,e,f,g,h) = ppParensCommasBlock [a,b,c,d,e,f,g,h]++instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h, PP i) => PP (a,b,c,d,e,f,g,h,i) where+ pp (a,b,c,d,e,f,g,h,i) = ppParensCommasBlock [a,b,c,d,e,f,g,h,i]++instance (PP a, PP b, PP c, PP d, PP e, PP f, PP g, PP h, PP i, PP j) => PP (a,b,c,d,e,f,g,h,i,j) where+ pp (a,b,c,d,e,f,g,h,i,j) = ppParensCommasBlock [a,b,c,d,e,f,g,h,i,j]+-}++-------------------------------------------------------------------------+-- Render+-------------------------------------------------------------------------++showPP :: PP a => a -> String+showPP x = disp (pp x) 1000 ""++-------------------------------------------------------------------------+-- PP printing to file+-------------------------------------------------------------------------++hPutLn :: Handle -> Int -> PP_Doc -> IO ()+{-+hPutLn h w pp+ = do hPut h pp w+ hPutStrLn h ""+-}+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+ }
+ src/CHR/Pretty/Simple.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE TypeSynonymInstances #-}++-------------------------------------------------------------------------+-- Subset of UU.Pretty, based on very simple pretty printing+-------------------------------------------------------------------------++module CHR.Pretty.Simple+ ( PP_Doc, PP(..)+ , disp+ , hPut+ , Doc(..)++ , (>|<), (>-<)+ , (>#<)+ , hlist, hlistReverse, vlist, hv+ , fill+ , indent++{-+ , pp_wrap, pp_quotes, pp_doubleQuotes, pp_parens, pp_brackets, pp_braces+ , ppPacked, ppParens, ppBrackets, ppBraces, ppCurlys+-}++ , empty, text+ + -- * Internal use only+ , isSingleLine+ )+ where++import System.IO+-- import Data.Data+import Data.Typeable++-------------------------------------------------------------------------+-- Doc structure+-------------------------------------------------------------------------++-- | Cached info about combi of sub Docs+data Cached = Cached+ { cchEmp :: !Bool -- ^ is it empty+ , cchSng :: !Bool -- ^ is it a single line+ }+ deriving (Typeable)++-- | Doc structure+data Doc+ = Emp+ | Str !String -- basic string+ | Hor !Cached !Doc !Doc -- horizontal positioning+ | Ver !Cached !Doc !Doc -- vertical positioning+ | Ind !Int !Doc -- indent+ deriving (Typeable)++type PP_Doc = Doc++-------------------------------------------------------------------------+-- Basic combinators+-------------------------------------------------------------------------++infixr 3 >|<, >#<+infixr 2 >-<++cached :: (PP a, PP b) => (PP_Doc -> PP_Doc -> Cached) -> (Cached -> PP_Doc -> PP_Doc -> PP_Doc) -> a -> b -> PP_Doc+cached cchd mk l r = mk (cchd l' r') l' r'+ where l' = pp l+ r' = pp r++-- | PP horizontally aside+(>|<) :: (PP a, PP b) => a -> b -> PP_Doc+l >|< r = cached mkcch Hor l r -- pp l `Hor` pp r+ where mkcch l r = Cached emp sng+ where emp = isEmpty l && isEmpty r+ sng = isSingleLine l && isSingleLine r++-- | PP vertically above+(>-<) :: (PP a, PP b) => a -> b -> PP_Doc+l >-< r = cached mkcch Ver l r -- pp l `Ver` pp r -- pp l <$$> pp r+ where mkcch l r = Cached (empl && empr) sng+ where empl = isEmpty l+ empr = isEmpty r+ sng = empl && isSingleLine r || empr && isSingleLine l++-- | PP horizontally aside with 1 blank in between+(>#<) :: (PP a, PP b) => a -> b -> PP_Doc+l >#< r = l >|< " " >|< r++-- | Indent+indent :: PP a => Int -> a -> PP_Doc+indent i d = Ind i $ pp d+{-# INLINE indent #-}++-- | basic string+text :: String -> PP_Doc+text = Str+{-# INLINE text #-}++-- | empty PP+empty :: PP_Doc+empty = Emp+{-# INLINE empty #-}++-------------------------------------------------------------------------+-- Derived combinators+-------------------------------------------------------------------------++vlist, hlist, hlistReverse :: PP a => [a] -> PP_Doc+-- | PP list horizontally+vlist [] = empty+vlist as = foldr (>-<) empty as++-- | PP list vertically+hlist [] = empty+hlist as = foldr (>|<) empty as++-- | PP list vertically reverse+hlistReverse [] = empty+hlistReverse as = foldr (flip (>|<)) empty as++-- | PP list vertically, alias for 'vlist'+hv :: PP a => [a] -> PP_Doc+hv = vlist++-- | PP list horizontally, alias for 'hlist'+fill :: PP a => [a] -> PP_Doc+fill = hlist++-------------------------------------------------------------------------+-- PP class+-------------------------------------------------------------------------++-- | Interface for PP+class Show a => PP a where+ pp :: a -> PP_Doc+ pp = text . show++ ppList :: [a] -> PP_Doc+ ppList as = hlist as++instance PP PP_Doc where+ pp = id++instance PP Char where+ pp c = text [c]+ ppList = text++instance PP a => PP [a] where+ pp = ppList++instance Show PP_Doc where+ show p = disp p 200 ""++instance PP Int where+ pp = text . show++instance PP Integer where+ pp = text . show++instance PP Float where+ pp = text . show++-------------------------------------------------------------------------+-- Observation+-------------------------------------------------------------------------++-- | Is empty doc?+isEmpty :: PP_Doc -> Bool+isEmpty Emp = True+isEmpty (Ver c d1 d2) = cchEmp c+isEmpty (Hor c d1 d2) = cchEmp c+isEmpty (Ind _ d ) = isEmpty d+isEmpty (Str _ ) = False++-- | Is single line doc?+isSingleLine :: PP_Doc -> Bool+isSingleLine Emp = True+isSingleLine (Ver c d1 d2) = cchSng c+isSingleLine (Hor c d1 d2) = cchSng c+isSingleLine (Ind _ d ) = isSingleLine d+isSingleLine (Str _ ) = True++-------------------------------------------------------------------------+-- Rendering+-------------------------------------------------------------------------++-- | Display to string+disp :: PP_Doc -> Int -> ShowS+disp d _ s+ = r+ where (r,_) = put 0 d s+ put p d s+ = case d of+ Emp -> (s,p)+ Str s' -> (s' ++ s,p + length s')+ Ind i d -> (ind ++ r,p')+ where (r,p') = put (p+i) d s+ ind = replicate i ' '+ Hor _ d1 d2 -> (r1,p2)+ where (r1,p1) = put p d1 r2+ (r2,p2) = put p1 d2 s+ Ver _ d1 d2 | isEmpty d1+ -> put p d2 s+ Ver _ d1 d2 | isEmpty d2+ -> put p d1 s+ Ver _ d1 d2 -> (r1,p2)+ where (r1,p1) = put p d1 $ "\n" ++ ind ++ r2+ (r2,p2) = put p d2 s+ ind = replicate p ' '++-- | Display to Handle+hPut :: Handle -> PP_Doc -> Int -> IO ()+hPut h d _+ = do _ <- put 0 d h+ return ()+ where put p d h+ = case d of+ Emp -> return p+ Str s -> do hPutStr h s+ return $ p + length s+ Ind i d -> do hPutStr h $ replicate i ' '+ put (p+i) d h+ Hor _ d1 d2 -> do p' <- put p d1 h+ put p' d2 h+ Ver _ d1 d2 | isEmpty d1+ -> put p d2 h+ Ver _ d1 d2 | isEmpty d2+ -> put p d1 h+ Ver _ d1 d2 -> do _ <- put p d1 h+ hPutStr h $ "\n" ++ replicate p ' '+ put p d2 h