summaryrefslogtreecommitdiff
path: root/ghc/compiler/utils
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/utils')
-rw-r--r--ghc/compiler/utils/Digraph.lhs2
-rw-r--r--ghc/compiler/utils/Outputable.lhs2
-rw-r--r--ghc/compiler/utils/Pretty.lhs49
-rw-r--r--ghc/compiler/utils/Util.lhs13
4 files changed, 37 insertions, 29 deletions
diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index 7ac34b2637..0dfc585c2d 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -153,7 +153,7 @@ graphFromEdges edges
edges1 = zipWith (,) [0..] sorted_edges
graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
+ key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
vertex_map = array bounds edges1
(_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False }
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 19ad666677..46cb73462c 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -179,7 +179,7 @@ printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
-- printForIface prints all on one line for interface files.
-- It's called repeatedly for successive lines
printForIface :: Handle -> SDoc -> IO ()
-printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
+printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index 1a3f70759c..6e2444860e 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -792,23 +792,12 @@ fillNB g p k ys = fill1 g p k ys
*********************************************************
\begin{code}
-best :: Mode
- -> Int -- Line length
+best :: Int -- Line length
-> Int -- Ribbon length
-> RDoc
-> RDoc -- No unions in here!
-best OneLineMode IBOX(w) IBOX(r) p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode IBOX(w) IBOX(r) p
+best IBOX(w) IBOX(r) p
= get w p
where
get :: INT -- (Remaining) width of line
@@ -858,7 +847,7 @@ minn x y | x LT y = x
first p q | nonEmptySet p = p
| otherwise = q
-nonEmptySet NoDoc = False
+nonEmptySet NoDoc = False
nonEmptySet (p `Union` q) = True
nonEmptySet Empty = True
nonEmptySet (NilAbove p) = True -- NoDoc always in first line
@@ -903,13 +892,30 @@ string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2
\begin{code}
-fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
+fullRender OneLineMode _ _ txt end doc
+ = lay (reduceDoc doc)
+ where
+ lay NoDoc = cant_fail
+ lay (Union p q) = (lay q) -- Second arg can't be NoDoc
+ lay (Nest k p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s sl p) = s `txt` lay p
+
+fullRender LeftMode _ _ txt end doc
+ = lay (reduceDoc doc)
+ where
+ lay NoDoc = cant_fail
+ lay (Union p q) = lay (first p q)
+ lay (Nest k p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s sl p) = s `txt` lay p
fullRender mode line_length ribbons_per_line txt end doc
= display mode line_length ribbon_length txt end best_doc
where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
+ best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
hacked_line_length, ribbon_length :: Int
ribbon_length = round (fromInt line_length / ribbons_per_line)
@@ -951,15 +957,6 @@ display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
}}
cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
| otherwise = spaces n
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 8e2198b050..2bb567db0a 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -28,7 +28,7 @@ module Util (
assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
- hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
+ hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
@@ -364,6 +364,17 @@ removeDups cmp xs
where
collect_dups dups_so_far [x] = (dups_so_far, x)
collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
+
+removeDupsEq :: Eq a => [a] -> ([a], [[a]])
+-- Same, but with only equality
+-- It's worst case quadratic, but we only use it on short lists
+removeDupsEq [] = ([], [])
+removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
+ where
+ (ys,zs) = removeDupsEq (filter (/= x) xs)
+removeDupsEq (x:xs) | otherwise = (x:ys, zs)
+ where
+ (ys,zs) = removeDupsEq xs
\end{code}
View Lorry Controller Status