diff --git a/src/UHC/Util/CompileRun.hs b/src/UHC/Util/CompileRun.hs --- a/src/UHC/Util/CompileRun.hs +++ b/src/UHC/Util/CompileRun.hs @@ -179,7 +179,7 @@ ppCR :: (PP n,PP u) => CompileRun n u i e -> PP_Doc ppCR cr = "CR" >#< show (crState cr) >|< ":" >#< - ( (ppListSepVV "[" "]" "," $ map (\(n,u) -> pp n >#< "->" >#< pp u) $ Map.toList $ crCUCache $ cr) + ( (ppBracketsCommasBlock $ map (\(n,u) -> pp n >#< "->" >#< pp u) $ Map.toList $ crCUCache $ cr) >-< ppBracketsCommas (map ppBracketsCommas $ crCompileOrder $ cr) ) diff --git a/src/UHC/Util/FastSeq.hs b/src/UHC/Util/FastSeq.hs --- a/src/UHC/Util/FastSeq.hs +++ b/src/UHC/Util/FastSeq.hs @@ -12,7 +12,9 @@ ) where -import Prelude hiding (null,map) +import Prelude hiding (null,map) +import Data.Monoid +import qualified Data.ListLike as LL import qualified Data.List as L import qualified UHC.Util.Utils as U @@ -37,6 +39,22 @@ empty = FSeqNil ------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------- + +instance Monoid (FastSeq a) where + mempty = empty + mappend = union + mconcat = unions + +{- +instance LL.FoldableLL (FastSeq a) a where + foldl op e seq = + +instance LL.ListLike (FastSeq a) a where +-} + +------------------------------------------------------------------------- -- Observations ------------------------------------------------------------------------- @@ -65,6 +83,32 @@ singleton :: a -> FastSeq a singleton = FSeq + +------------------------------------------------------------------------- +-- Deconstruction +------------------------------------------------------------------------- + +-- | View as head and tail, if possible +viewMbCons :: FastSeq a -> Maybe (a, FastSeq a) +viewMbCons FSeqNil = Nothing +viewMbCons (FSeq x) = Just (x, FSeqNil) +viewMbCons (FSeqL (h:t)) = Just (h, FSeqL t) +viewMbCons (FSeqL [] ) = Nothing +viewMbCons (h :+:: t ) = Just (h, t) +viewMbCons (i ::+: l ) = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbCons i +viewMbCons (s1 :++: s2) = maybe (viewMbCons s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbCons s1 + +{- +-- | View as init and last, if possible +viewMbSnoc :: FastSeq a -> Maybe (FastSeq a, a) +viewMbSnoc FSeqNil = Nothing +viewMbSnoc (FSeqL (h:t)) = Just (h, FSeqL t) +viewMbSnoc (FSeqL [] ) = Nothing +viewMbSnoc (h :+:: t ) = Just (h, t) +viewMbSnoc (i ::+: l ) = maybe (Just (l, FSeqNil)) (\(h,t) -> Just (h, t ::+: l)) $ viewMbSnoc i +viewMbSnoc (s1 :++: s2) = maybe (viewMbSnoc s2) (\(h,t) -> Just (h, t :++: s2)) $ viewMbSnoc s1 +-} + ------------------------------------------------------------------------- -- Conversion diff --git a/src/UHC/Util/Pretty.hs b/src/UHC/Util/Pretty.hs --- a/src/UHC/Util/Pretty.hs +++ b/src/UHC/Util/Pretty.hs @@ -11,29 +11,67 @@ , PP_DocL + -- * Choice combinators + , (>-|-<) + , (>-#-<) + + -- * General PP for list , ppListSep, ppListSepV, ppListSepVV - , ppBlock, ppBlock' - , ppCommas, ppCommas' - , ppSemis, ppSemis' - , ppSpaces + + -- * Pack PP around , ppCurlys + , ppPacked + , ppPackedWithStrings + , ppParens + , ppCurly + , ppBrackets + , ppVBar + + -- * Block, horizontal/vertical as required + , ppBlock, ppBlockH + , ppBlock' + , ppBlockWithStrings, ppBlockWithStrings' + + , 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' - , ppParensSemisBlock - , ppParensCommasBlock - , ppBrackets - , ppBracketsCommas, ppBracketsCommas', ppBracketsCommasV - , ppHorizontally, ppVertically + , ppBracketsCommas + , ppBracketsCommas' + , ppHorizontally , ppListSepFill - , ppPacked, ppParens, ppCurly, ppVBar + -- * Conditional + , ppMbPre, ppMbPost + , ppListPre, ppListPost + -- * Misc , ppDots, ppMb, ppUnless, ppWhen + -- * IO , hPutWidthPPLn, putWidthPPLn , hPutPPLn, putPPLn , hPutPPFile, putPPFile @@ -44,6 +82,7 @@ -- import UU.Pretty -- import UHC.Util.Chitil.Pretty import UHC.Util.PrettySimple +import UHC.Util.Utils import UHC.Util.FPath import System.IO import Data.List @@ -54,8 +93,9 @@ 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 o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c +ppListSep = ppListSepWith pp -- o >|< hlist (intersperse (pp s) (map pp pps)) >|< c {- ppListSep o c s pps = o >|< l pps >|< c @@ -64,74 +104,183 @@ l (p:ps) = pp p >|< map (s >|<) ps -} -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 +-- | 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 -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] +{-# 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 -ppBlock :: (PP ocs,PP a) => ocs -> ocs -> ocs -> [a] -> PP_Doc -ppBlock o c s = vlist . ppBlock' o c s +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 +ppBlock' :: (PP ocs, PP a) => ocs -> ocs -> ocs -> ocs -> [a] -> [PP_Doc] +ppBlock' = ppBlock'' False +{-# INLINE ppBlock' #-} + +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 +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 +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 = ppBlock "{ " "}" " " . map pp +ppCurlysBlock = ppBlockWithStrings "{" "}" " " +{-# INLINE ppCurlysBlock #-} +-- | PP horizontally or vertically with "{", " ", and "}" in a possibly multiline block structure +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 = ppBlock "{ " "}" "; " . map pp +ppCurlysSemisBlock = ppBlockWithStrings "{" "}" "; " +{-# INLINE ppCurlysSemisBlock #-} +-- | PP horizontally or vertically with "{", ";", and "}" in a possibly multiline block structure +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 = ppBlock "{ " "}" ", " . map pp +ppCurlysCommasBlock = ppBlockWithStrings "{" "}" ", " +{-# INLINE ppCurlysCommasBlock #-} +-- | PP horizontally or vertically with "{", ",", and "}" in a possibly multiline block structure +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 = ppBlock "( " ")" "; " . map pp +ppParensSemisBlock = ppBlockWithStrings "(" ")" "; " +{-# INLINE ppParensSemisBlock #-} +-- | PP horizontally or vertically with "(", ";", and ")" in a possibly multiline block structure +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 = ppBlock "( " ")" ", " . map pp +ppParensCommasBlock = ppBlockWithStrings "(" ")" ", " +{-# INLINE ppParensCommasBlock #-} +-- | PP horizontally or vertically with "(", ",", and ")" in a possibly multiline block structure +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 "[" "]" "," -ppBracketsCommasV :: PP a => [a] -> PP_Doc -ppBracketsCommasV = ppListSepV3 "[ " "]" ", " - +-- | 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 = ppListSepWith "{" "}" "," +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 "{" "}" "; " @@ -140,6 +289,7 @@ 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 @@ -148,13 +298,13 @@ 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 @@ -163,32 +313,14 @@ ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc ppListSepVV = ppListSepV' (>-<) -{- -ppListSepV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc -ppListSepV o c s pps - = l pps - where l [] = o >|< c - l [p] = ppPacked o c p - l (p:ps) = vlist ([o >|< p] ++ map (s >|<) (init ps) ++ [s >|< last ps >|< c]) - -ppListSepVV :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc -ppListSepVV o c s pps - = o >-< foldr (\l r -> l >-< s >-< r) empty pps >-< c --} - +-- | Alias for 'vlist' ppVertically :: [PP_Doc] -> PP_Doc ppVertically = vlist +-- | Alias for 'hlist' 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 - ------------------------------------------------------------------------- -- Printing open/close pairs ------------------------------------------------------------------------- @@ -197,14 +329,65 @@ 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 = ppPacked "(" ")" -ppBrackets = ppPacked "[" "]" -ppCurly = ppPacked "{" "}" +ppParens = ppPackedWithStrings "(" ")" +ppBrackets = ppPackedWithStrings "[" "]" +ppCurly = ppPackedWithStrings "{" "}" ppCurlys = ppCurly -ppVBar = ppPacked "|" "| " +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 +------------------------------------------------------------------------- + +-- | 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 ------------------------------------------------------------------------- @@ -214,17 +397,44 @@ 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 +------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------- instance PP a => PP (Maybe a) where pp = maybe (pp "?") pp instance PP Bool where pp = pp . show + +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) = ppParensCommasBlock [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] +-} ------------------------------------------------------------------------- -- PP printing to file diff --git a/src/UHC/Util/PrettySimple.hs b/src/UHC/Util/PrettySimple.hs --- a/src/UHC/Util/PrettySimple.hs +++ b/src/UHC/Util/PrettySimple.hs @@ -21,6 +21,9 @@ -} , empty, text + + -- * Internal use only + , isSingleLine ) where @@ -30,12 +33,19 @@ -- Doc structure ------------------------------------------------------------------------- +-- | Cached info about combi of sub Docs +data Cached = Cached + { cchEmp :: !Bool -- ^ is it empty + , cchSng :: !Bool -- ^ is it a single line + } + +-- | Doc structure data Doc = Emp | Str !String -- basic string - | Hor Doc !Doc -- horizontal positioning - | Ver Doc !Doc -- vertical positioning - | Ind !Int Doc -- indent + | Hor !Cached !Doc !Doc -- horizontal positioning + | Ver !Cached !Doc !Doc -- vertical positioning + | Ind !Int !Doc -- indent type PP_Doc = Doc @@ -46,37 +56,63 @@ 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 = pp l `Hor` pp r +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 = pp l `Ver` pp r -- pp l <$$> pp r +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 ------------------------------------------------------------------------- hlist, vlist :: 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, 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 @@ -84,6 +120,7 @@ -- PP class ------------------------------------------------------------------------- +-- | Interface for PP class Show a => PP a where pp :: a -> PP_Doc pp = text . show @@ -107,6 +144,9 @@ instance PP Int where pp = text . show +instance PP Integer where + pp = text . show + instance PP Float where pp = text . show @@ -114,17 +154,27 @@ -- Observation ------------------------------------------------------------------------- +-- | Is empty doc? isEmpty :: PP_Doc -> Bool -isEmpty Emp = True -isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2 -isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2 -isEmpty (Ind _ d ) = isEmpty d -isEmpty _ = False +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 @@ -136,18 +186,19 @@ Ind i d -> (ind ++ r,p') where (r,p') = put (p+i) d s ind = replicate i ' ' - Hor d1 d2 -> (r1,p2) + Hor _ d1 d2 -> (r1,p2) where (r1,p1) = put p d1 r2 (r2,p2) = put p1 d2 s - Ver d1 d2 | isEmpty d1 + Ver _ d1 d2 | isEmpty d1 -> put p d2 s - Ver d1 d2 | isEmpty d2 + Ver _ d1 d2 | isEmpty d2 -> put p d1 s - Ver d1 d2 -> (r1,p2) + 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 @@ -159,12 +210,12 @@ 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 + Hor _ d1 d2 -> do p' <- put p d1 h put p' d2 h - Ver d1 d2 | isEmpty d1 + Ver _ d1 d2 | isEmpty d1 -> put p d2 h - Ver d1 d2 | isEmpty d2 + Ver _ d1 d2 | isEmpty d2 -> put p d1 h - Ver d1 d2 -> do _ <- put p d1 h + Ver _ d1 d2 -> do _ <- put p d1 h hPutStr h $ "\n" ++ replicate p ' ' put p d2 h diff --git a/src/UHC/Util/Utils.hs b/src/UHC/Util/Utils.hs --- a/src/UHC/Util/Utils.hs +++ b/src/UHC/Util/Utils.hs @@ -275,3 +275,13 @@ mapLookup2 :: (Ord k1, Ord k2) => k1 -> k2 -> Map.Map k1 (Map.Map k2 v2) -> Maybe v2 mapLookup2 k1 k2 m1 = fmap snd $ mapLookup2' id k1 k2 m1 {-# INLINE mapLookup2 #-} + +------------------------------------------------------------------------- +-- Monad +------------------------------------------------------------------------- + +-- | loop over monads yielding a Maybe from a start value, yielding the first Just or the start (when no Just is returned) +firstMaybeM :: Monad m => a -> [a -> m (Maybe a)] -> m a +firstMaybeM x [] = return x +firstMaybeM x (s:ss) = do mx <- s x + maybe (firstMaybeM x ss) return mx diff --git a/src/UHC/Util/VarMp.hs b/src/UHC/Util/VarMp.hs --- a/src/UHC/Util/VarMp.hs +++ b/src/UHC/Util/VarMp.hs @@ -519,10 +519,10 @@ ] instance (PP k, PP v) => PP (VarMp' k v) where - pp = ppVarMp (ppListSepFill "" "" ", ") + pp = ppVarMp (ppCommas') instance (PP k, PP v) => PP (VarMpStk' k v) where - pp (VarMpStk s) = ppListSepFill "" "" "; " $ map pp s + pp (VarMpStk s) = ppSemis' $ map pp s {- ppVarMpInfoCfgTy :: CfgPPTy -> VarMpInfo -> PP_Doc diff --git a/uhc-util.cabal b/uhc-util.cabal --- a/uhc-util.cabal +++ b/uhc-util.cabal @@ -1,5 +1,5 @@ Name: uhc-util -Version: 0.1.2.0 +Version: 0.1.3.0 cabal-version: >= 1.6 License: BSD3 Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group @@ -32,6 +32,7 @@ uulib >= 0.9 && < 1, time-compat >= 0.1.0.1 && < 0.2, time >= 1.2 && < 1.5, + ListLike >= 4.0.0, syb >= 0.3.6 Exposed-Modules: UHC.Util.AGraph,