packages feed

uhc-util 0.1.2.0 → 0.1.3.0

raw patch · 7 files changed

+397/−81 lines, 7 filesdep +ListLike

Dependencies added: ListLike

Files

src/UHC/Util/CompileRun.hs view
@@ -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)       )
src/UHC/Util/FastSeq.hs view
@@ -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
src/UHC/Util/Pretty.hs view
@@ -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
src/UHC/Util/PrettySimple.hs view
@@ -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
src/UHC/Util/Utils.hs view
@@ -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
src/UHC/Util/VarMp.hs view
@@ -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
uhc-util.cabal view
@@ -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,