diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for chr-pretty + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chr-pretty.cabal b/chr-pretty.cabal new file mode 100644 --- /dev/null +++ b/chr-pretty.cabal @@ -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 diff --git a/src/CHR/Pretty.hs b/src/CHR/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/CHR/Pretty.hs @@ -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 + } diff --git a/src/CHR/Pretty/Simple.hs b/src/CHR/Pretty/Simple.hs new file mode 100644 --- /dev/null +++ b/src/CHR/Pretty/Simple.hs @@ -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