diff options
| -rw-r--r-- | compiler/utils/Bag.hs (renamed from compiler/utils/Bag.lhs) | 17 | ||||
| -rw-r--r-- | compiler/utils/Digraph.hs (renamed from compiler/utils/Digraph.lhs) | 186 | ||||
| -rw-r--r-- | compiler/utils/FastBool.hs (renamed from compiler/utils/FastBool.lhs) | 10 | ||||
| -rw-r--r-- | compiler/utils/FastFunctions.hs (renamed from compiler/utils/FastFunctions.lhs) | 9 | ||||
| -rw-r--r-- | compiler/utils/FastMutInt.hs (renamed from compiler/utils/FastMutInt.lhs) | 5 | ||||
| -rw-r--r-- | compiler/utils/FastString.hs (renamed from compiler/utils/FastString.lhs) | 7 | ||||
| -rw-r--r-- | compiler/utils/FastTypes.hs (renamed from compiler/utils/FastTypes.lhs) | 10 | ||||
| -rw-r--r-- | compiler/utils/FiniteMap.hs (renamed from compiler/utils/FiniteMap.lhs) | 5 | ||||
| -rw-r--r-- | compiler/utils/ListSetOps.hs (renamed from compiler/utils/ListSetOps.lhs) | 67 | ||||
| -rw-r--r-- | compiler/utils/Maybes.hs (renamed from compiler/utils/Maybes.lhs) | 49 | ||||
| -rw-r--r-- | compiler/utils/OrdList.hs (renamed from compiler/utils/OrdList.lhs) | 11 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs (renamed from compiler/utils/Outputable.lhs) | 130 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs-boot (renamed from compiler/utils/Outputable.lhs-boot) | 4 | ||||
| -rw-r--r-- | compiler/utils/Pair.hs (renamed from compiler/utils/Pair.lhs) | 5 | ||||
| -rw-r--r-- | compiler/utils/Panic.hs (renamed from compiler/utils/Panic.lhs) | 12 | ||||
| -rw-r--r-- | compiler/utils/Pretty.hs (renamed from compiler/utils/Pretty.lhs) | 207 | ||||
| -rw-r--r-- | compiler/utils/StringBuffer.hs (renamed from compiler/utils/StringBuffer.lhs) | 12 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.hs (renamed from compiler/utils/UniqFM.lhs) | 61 | ||||
| -rw-r--r-- | compiler/utils/UniqSet.hs (renamed from compiler/utils/UniqSet.lhs) | 38 | ||||
| -rw-r--r-- | compiler/utils/Util.hs (renamed from compiler/utils/Util.lhs) | 208 |
20 files changed, 446 insertions, 607 deletions
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.hs index 65c5b39df1..95feaed9f8 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Bag: an unordered collection with duplicates +-} -\begin{code} {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Bag ( @@ -32,10 +32,7 @@ import Data.List ( partition ) infixr 3 `consBag` infixl 3 `snocBag` -\end{code} - -\begin{code} data Bag a = EmptyBag | UnitBag a @@ -257,9 +254,7 @@ listToBag vs = ListBag vs bagToList :: Bag a -> [a] bagToList b = foldrBag (:) [] b -\end{code} -\begin{code} instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) @@ -269,5 +264,3 @@ instance Data a => Data (Bag a) where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" dataCast1 x = gcast1 x -\end{code} - diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.hs index 35782bac6e..8f5df0ce05 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.hs @@ -1,8 +1,5 @@ -% -% (c) The University of Glasgow 2006 -% +-- (c) The University of Glasgow 2006 -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, @@ -58,13 +55,13 @@ import Data.Ord import Data.Array.ST import qualified Data.Map as Map import qualified Data.Set as Set -\end{code} -%************************************************************************ -%* * -%* Graphs and Graph Construction -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ Note [Nodes, keys, vertices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -75,8 +72,8 @@ Note [Nodes, keys, vertices] * Digraph then maps each 'key' to a Vertex (Int) which is arranged densely in 0.n +-} -\begin{code} data Graph node = Graph { gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, @@ -151,15 +148,15 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte LT -> find a (mid - 1) EQ -> Just mid GT -> find (mid + 1) b -\end{code} -%************************************************************************ -%* * -%* SCC -%* * -%************************************************************************ +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} -\begin{code} type WorkItem key payload = (Node key payload, -- Tip of the path [payload]) -- Rest of the path; @@ -208,15 +205,15 @@ findCycle graph new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] -\end{code} -%************************************************************************ -%* * -%* SCC -%* * -%************************************************************************ +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} -\begin{code} data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] @@ -234,19 +231,19 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) -\end{code} -%************************************************************************ -%* * -%* Strongly Connected Component wrappers for Graph -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ Note: the components are returned topologically sorted: later components depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. +-} -\begin{code} stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG graph = decodeSccs graph forest where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) @@ -278,15 +275,15 @@ stronglyConnCompFromEdgedVerticesR => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices -\end{code} -%************************************************************************ -%* * -%* Misc wrappers for Graph -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} -\begin{code} topologicalSortG :: Graph node -> [node] topologicalSortG graph = map (gr_vertex_to_node graph) result where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) @@ -340,15 +337,14 @@ emptyG g = graphEmpty (gr_int_graph g) componentsG :: Graph node -> [[node]] componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph) -\end{code} -%************************************************************************ -%* * -%* Showing Graphs -%* * -%************************************************************************ - -\begin{code} +{- +************************************************************************ +* * +* Showing Graphs +* * +************************************************************************ +-} instance Outputable node => Outputable (Graph node) where ppr graph = vcat [ @@ -359,23 +355,20 @@ instance Outputable node => Outputable (Graph node) where instance Outputable node => Outputable (Edge node) where ppr (Edge from to) = ppr from <+> text "->" <+> ppr to -\end{code} - -%************************************************************************ -%* * -%* IntGraphs -%* * -%************************************************************************ +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} -\begin{code} type Vertex = Int type Table a = Array Vertex a type IntGraph = Table [Vertex] type Bounds = (Vertex, Vertex) type IntEdge = (Vertex, Vertex) -\end{code} -\begin{code} vertices :: IntGraph -> [Vertex] vertices = indices @@ -405,15 +398,14 @@ graphEmpty :: IntGraph -> Bool graphEmpty g = lo > hi where (lo, hi) = bounds g -\end{code} - -%************************************************************************ -%* * -%* Trees and forests -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Trees and forests +* * +************************************************************************ +-} -\begin{code} data Tree a = Node a (Forest a) type Forest a = [Tree a] @@ -422,9 +414,7 @@ mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) flattenTree :: Tree a -> [a] flattenTree (Node x ts) = x : concatMap flattenTree ts -\end{code} -\begin{code} instance Show a => Show (Tree a) where showsPrec _ t s = showTree t ++ s @@ -451,16 +441,15 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts) grp fst rst = zipWith (++) (fst:repeat rst) [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"] -\end{code} +{- +************************************************************************ +* * +* Depth first search +* * +************************************************************************ +-} -%************************************************************************ -%* * -%* Depth first search -%* * -%************************************************************************ - -\begin{code} type Set s = STArray s Vertex Bool mkEmpty :: Bounds -> ST s (Set s) @@ -471,9 +460,7 @@ contains m v = readArray m v include :: Set s -> Vertex -> ST s () include m v = writeArray m v True -\end{code} -\begin{code} dff :: IntGraph -> Forest Vertex dff g = dfs g (vertices g) @@ -498,20 +485,19 @@ chop m (Node v ts : us) chop m ts >>= \as -> chop m us >>= \bs -> return (Node v as : bs) -\end{code} - -%************************************************************************ -%* * -%* Algorithms -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Algorithms +* * +************************************************************************ ------------------------------------------------------------ -- Algorithm 1: depth first search numbering ------------------------------------------------------------ +-} -\begin{code} preorder :: Tree a -> [a] preorder (Node a ts) = a : preorderF ts @@ -523,13 +509,13 @@ tabulate bnds vs = array bnds (zip vs [1..]) preArr :: Bounds -> Forest Vertex -> Table Int preArr bnds = tabulate bnds . preorderF -\end{code} +{- ------------------------------------------------------------ -- Algorithm 2: topological sorting ------------------------------------------------------------ +-} -\begin{code} postorder :: Tree a -> [a] -> [a] postorder (Node a ts) = postorderF ts . (a :) @@ -541,34 +527,34 @@ postOrd g = postorderF (dff g) [] topSort :: IntGraph -> [Vertex] topSort = reverse . postOrd -\end{code} +{- ------------------------------------------------------------ -- Algorithm 3: connected components ------------------------------------------------------------ +-} -\begin{code} components :: IntGraph -> Forest Vertex components = dff . undirected undirected :: IntGraph -> IntGraph undirected g = buildG (bounds g) (edges g ++ reverseE g) -\end{code} +{- ------------------------------------------------------------ -- Algorithm 4: strongly connected components ------------------------------------------------------------ +-} -\begin{code} scc :: IntGraph -> Forest Vertex scc g = dfs g (reverse (postOrd (transpose g))) -\end{code} +{- ------------------------------------------------------------ -- Algorithm 5: Classifying edges ------------------------------------------------------------ +-} -\begin{code} back :: IntGraph -> Table Int -> IntGraph back g post = mapT select g where select v ws = [ w | w <- ws, post!v < post!w ] @@ -580,25 +566,25 @@ cross g pre post = mapT select g forward :: IntGraph -> IntGraph -> Table Int -> IntGraph forward g tree pre = mapT select g where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v -\end{code} +{- ------------------------------------------------------------ -- Algorithm 6: Finding reachable vertices ------------------------------------------------------------ +-} -\begin{code} reachable :: IntGraph -> [Vertex] -> [Vertex] reachable g vs = preorderF (dfs g vs) path :: IntGraph -> Vertex -> Vertex -> Bool path g v w = w `elem` (reachable g [v]) -\end{code} +{- ------------------------------------------------------------ -- Algorithm 7: Biconnected components ------------------------------------------------------------ +-} -\begin{code} bcc :: IntGraph -> Forest [Vertex] bcc g = (concat . map bicomps . map (do_label g dnum)) forest where forest = dff g @@ -620,8 +606,8 @@ collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv] cs = concat [ if lw<dv then us else [Node (v:ws) us] | (lw, Node ws us) <- collected ] -\end{code} +{- ------------------------------------------------------------ -- Algorithm 8: Total ordering on groups of vertices ------------------------------------------------------------ @@ -637,8 +623,7 @@ We proceed by iteratively removing elements with no outgoing edges and their associated edges from the graph. This probably isn't very efficient and certainly isn't very clever. - -\begin{code} +-} vertexGroups :: IntGraph -> [[Vertex]] vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices) @@ -665,4 +650,3 @@ vertexGroupsS provided g to_provide vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v)) -\end{code} diff --git a/compiler/utils/FastBool.lhs b/compiler/utils/FastBool.hs index 9aa1a75b37..9e88376f0a 100644 --- a/compiler/utils/FastBool.lhs +++ b/compiler/utils/FastBool.hs @@ -1,9 +1,9 @@ -% -% (c) The University of Glasgow, 2000-2006 -% +{- +(c) The University of Glasgow, 2000-2006 + \section{Fast booleans} +-} -\begin{code} {-# LANGUAGE CPP, MagicHash #-} module FastBool ( @@ -68,5 +68,3 @@ fastBool :: Bool -> FastBool isFastTrue :: FastBool -> Bool fastOr :: FastBool -> FastBool -> FastBool fastAnd :: FastBool -> FastBool -> FastBool - -\end{code} diff --git a/compiler/utils/FastFunctions.lhs b/compiler/utils/FastFunctions.hs index 854bd13b11..140e42949a 100644 --- a/compiler/utils/FastFunctions.lhs +++ b/compiler/utils/FastFunctions.hs @@ -1,9 +1,10 @@ +{- Z% -% (c) The University of Glasgow, 2000-2006 -% +(c) The University of Glasgow, 2000-2006 + \section{Fast functions} +-} -\begin{code} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module FastFunctions ( @@ -43,5 +44,3 @@ global a = unsafePerformIO (newIORef a) indexWord8OffFastPtr :: FastPtr Word8 -> FastInt -> Word8 indexWord8OffFastPtrAsFastChar :: FastPtr Word8 -> FastInt -> FastChar indexWord8OffFastPtrAsFastInt :: FastPtr Word8 -> FastInt -> FastInt - -\end{code} diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.hs index e866aa5d38..4cde1216ed 100644 --- a/compiler/utils/FastMutInt.lhs +++ b/compiler/utils/FastMutInt.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised @@ -32,9 +31,7 @@ writeFastMutInt :: FastMutInt -> Int -> IO () newFastMutPtr :: IO FastMutPtr readFastMutPtr :: FastMutPtr -> IO (Ptr a) writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () -\end{code} -\begin{code} data FastMutInt = FastMutInt (MutableByteArray# RealWorld) newFastMutInt = IO $ \s -> @@ -64,5 +61,3 @@ readFastMutPtr (FastMutPtr arr) = IO $ \s -> writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> case writeAddrArray# arr 0# i s of { s -> (# s, () #) } -\end{code} - diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.hs index c1f7973e76..9607d24823 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.hs @@ -1,7 +1,5 @@ -% -% (c) The University of Glasgow, 1997-2006 -% -\begin{code} +-- (c) The University of Glasgow, 1997-2006 + {-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised @@ -640,4 +638,3 @@ fsLit x = mkFastString x forall x . sLit (unpackCString# x) = mkLitString# x #-} {-# RULES "fslit" forall x . fsLit (unpackCString# x) = mkFastString# x #-} -\end{code} diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.hs index 6b1517c484..a5c1aa9637 100644 --- a/compiler/utils/FastTypes.lhs +++ b/compiler/utils/FastTypes.hs @@ -1,9 +1,9 @@ -% -% (c) The University of Glasgow, 2000-2006 -% +{- +(c) The University of Glasgow, 2000-2006 + \section{Fast integers, etc... booleans moved to FastBool for using panic} +-} -\begin{code} {-# LANGUAGE CPP, MagicHash #-} --Even if the optimizer could handle boxed arithmetic equally well, @@ -136,5 +136,3 @@ eqFastChar :: FastChar -> FastChar -> Bool pBox :: FastPtr a -> Ptr a pUnbox :: Ptr a -> FastPtr a castFastPtr :: FastPtr a -> FastPtr b - -\end{code} diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.hs index b52f28c324..dccfca10a9 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.hs @@ -1,6 +1,5 @@ -Some extra functions to extend Data.Map +-- Some extra functions to extend Data.Map -\begin{code} module FiniteMap ( insertList, insertListWith, @@ -28,5 +27,3 @@ foldRight :: (elt -> a -> a) -> a -> Map key elt -> a foldRight = Map.fold foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a foldRightWithKey = Map.foldrWithKey -\end{code} - diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.hs index 6247dc67f6..54faa4f600 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[ListSetOps]{Set-like operations on lists} +-} -\begin{code} {-# LANGUAGE CPP #-} module ListSetOps ( @@ -29,8 +29,8 @@ import UniqFM import Util import Data.List -\end{code} +{- --------- #ifndef DEBUG getNth :: [a] -> Int -> a @@ -41,20 +41,21 @@ getNth xs n = ASSERT2( xs `lengthAtLeast` n, ppr n $$ ppr xs ) xs !! n #endif ---------- -\begin{code} +-} + getNth :: Outputable a => [a] -> Int -> a getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) xs !! n -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Treating lists as sets Assumes the lists contain no duplicates, but are unordered -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} insertList :: Eq a => a -> [a] -> [a] -- Assumes the arg list contains no dups; guarantees the result has no dups insertList x xs | isIn "insert" x xs = xs @@ -62,25 +63,24 @@ insertList x xs | isIn "insert" x xs = xs unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] -- Assumes that the arguments contain no duplicates -unionLists xs ys +unionLists xs ys = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys) [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys minusList :: (Eq a) => [a] -> [a] -> [a] -- Everything in the first list that is not in the second list: minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-assoc]{Association lists} -%* * -%************************************************************************ +* * +************************************************************************ Inefficient finite maps based on association lists and equality. +-} -\begin{code} -- A finite mapping based on equality and association lists type Assoc a b = [(a,b)] @@ -104,15 +104,15 @@ assocMaybe alist key where lookup [] = Nothing lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-dups]{Duplicate-handling} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} hasNoDups :: (Eq a) => [a] -> Bool hasNoDups xs = f [] xs @@ -123,9 +123,7 @@ hasNoDups xs = f [] xs else f (x:seen_so_far) xs is_elem = isIn "hasNoDups" -\end{code} -\begin{code} equivClasses :: (a -> a -> Ordering) -- Comparison -> [a] -> [[a]] @@ -135,16 +133,16 @@ equivClasses _ stuff@[_] = [stuff] equivClasses cmp items = runs eq (sortBy cmp items) where eq a b = case cmp a b of { EQ -> True; _ -> False } -\end{code} +{- The first cases in @equivClasses@ above are just to cut to the point more quickly... @runs@ groups a list into a list of lists, each sublist being a run of identical elements of the input list. It is passed a predicate @p@ which tells when two elements are equal. +-} -\begin{code} runs :: (a -> a -> Bool) -- Equality -> [a] -> [[a]] @@ -152,9 +150,7 @@ runs :: (a -> a -> Bool) -- Equality runs _ [] = [] runs p (x:xs) = case (span (p x) xs) of (first, rest) -> (x:first) : (runs p rest) -\end{code} -\begin{code} removeDups :: (a -> a -> Ordering) -- Comparison function -> [a] -> ([a], -- List with no duplicates @@ -176,10 +172,7 @@ findDupsEq _ [] = [] findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs | otherwise = (x:eq_xs) : findDupsEq eq neq_xs where (eq_xs, neq_xs) = partition (eq x) xs -\end{code} - -\begin{code} equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]] -- NB: it's *very* important that if we have the input list [a,b,c], -- where a,b,c all have the same unique, then we get back the list @@ -192,5 +185,3 @@ equivClassesByUniq get_uniq xs where add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a] tack_on old new = new++old -\end{code} - diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.hs index 8052b1d848..fc8e3199ae 100644 --- a/compiler/utils/Maybes.lhs +++ b/compiler/utils/Maybes.hs @@ -1,9 +1,8 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} -\begin{code} {-# LANGUAGE CPP #-} module Maybes ( module Data.Maybe, @@ -25,15 +24,15 @@ import Control.Monad import Data.Maybe infixr 4 `orElse` -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Maybe type]{The @Maybe@ type} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} firstJust :: Maybe a -> Maybe a -> Maybe a firstJust a b = firstJusts [a, b] @@ -54,15 +53,14 @@ whenIsJust Nothing _ = return () -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a orElse = flip fromMaybe -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[MaybeT type]{The @MaybeT@ monad transformer} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)} @@ -78,16 +76,14 @@ instance Monad m => Monad (MaybeT m) where x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f) fail _ = MaybeT $ return Nothing -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[MaybeErr type]{The @MaybeErr@ type} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data MaybeErr err val = Succeeded val | Failed err instance Functor (MaybeErr err) where @@ -108,4 +104,3 @@ isSuccess (Failed {}) = False failME :: err -> MaybeErr err val failME e = Failed e -\end{code} diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.hs index 42abb51696..ad72ca1d45 100644 --- a/compiler/utils/OrdList.lhs +++ b/compiler/utils/OrdList.hs @@ -1,14 +1,14 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1993-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + This is useful, general stuff for the Native Code Generator. Provide trees (of instructions), so that lists of instructions can be appended in linear time. +-} -\begin{code} module OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, @@ -96,4 +96,3 @@ foldlOL k z (Many xs) = foldl k z xs toOL :: [a] -> OrdList a toOL [] = None toOL xs = Many xs -\end{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.hs index a4ba48c609..488094a498 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.hs @@ -1,9 +1,8 @@ -% -% (c) The University of Glasgow 2006-2012 -% (c) The GRASP Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} -\begin{code} -- | This module defines classes and functions for pretty-printing. It also -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. -- @@ -105,17 +104,14 @@ import Text.Printf import GHC.Fingerprint import GHC.Show ( showMultiLineString ) -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The @PprStyle@ data type} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} data PprStyle = PprUser PrintUnqualified Depth @@ -246,8 +242,8 @@ mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth -\end{code} +{- Orthogonal to the above printing styles are (possibly) some command-line flags that affect printing (often carried with the style). The most likely ones are variations on how much type info is @@ -256,13 +252,13 @@ shown. The following test decides whether or not we are actually generating code (either C or assembly), or generating interface files. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{The @SDoc@ data type} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } data SDocContext = SDC @@ -294,7 +290,7 @@ pprDeeper d = SDoc $ \ctx -> case ctx of pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds +pprDeeperList f ds | null ds = f [] | otherwise = SDoc work where @@ -324,9 +320,7 @@ sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx sdocWithPlatform :: (Platform -> SDoc) -> SDoc sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) -\end{code} -\begin{code} qualName :: PprStyle -> QueryQualifyName qualName (PprUser q _) mod occ = queryQualifyName q mod occ qualName (PprDump q) mod occ = queryQualifyName q mod occ @@ -372,9 +366,6 @@ ifPprDebug d = SDoc $ \ctx -> case ctx of SDC{sdocStyle=PprDebug} -> runSDoc d ctx _ -> Pretty.empty -\end{code} - -\begin{code} printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () printForUser dflags handle unqual doc @@ -452,9 +443,7 @@ showSDocDumpOneLine dflags d irrelevantNCols :: Int -- Used for OneLineMode and LeftMode when number of cols isn't used irrelevantNCols = 1 -\end{code} -\begin{code} docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) @@ -485,7 +474,7 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n -parens, braces, brackets, quotes, quote, +parens, braces, brackets, quotes, quote, paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc parens d = SDoc $ Pretty.parens . runSDoc d @@ -655,16 +644,14 @@ bold = coloured colBold keyword :: SDoc -> SDoc keyword = bold -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Outputable-class]{The @Outputable@ class} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Class designating that some type has an 'SDoc' representation class Outputable a where ppr :: a -> SDoc @@ -675,9 +662,7 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr -\end{code} -\begin{code} instance Outputable Char where ppr c = text [c] @@ -779,15 +764,15 @@ instance (Outputable elt) => Outputable (IM.IntMap elt) where instance Outputable Fingerprint where ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The @OutputableBndr@ class} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | 'BindingSite' is used to tell the thing that prints binder what -- language construct is binding the identifier. This can be used -- to decide how much info to print. @@ -800,18 +785,18 @@ class Outputable a => OutputableBndr a where pprBndr _b x = ppr x pprPrefixOcc, pprInfixOcc :: a -> SDoc - -- Print an occurrence of the name, suitable either in the + -- Print an occurrence of the name, suitable either in the -- prefix position of an application, thus (f a b) or ((+) x) -- or infix position, thus (a `f` b) or (x + y) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Random printing helpers} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- We have 31-bit Chars and will simply use Show instances of Char and String. -- | Special combinator for showing character literals. @@ -849,15 +834,15 @@ pprInfixVar is_operator pp_v --------------------- pprFastFilePath :: FastString -> SDoc pprFastFilePath path = text $ normalise $ unpackFS path -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Other helper functions} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use -> [a] -- ^ The things to be pretty printed -> SDoc -- ^ 'SDoc' where the things have been pretty printed, @@ -885,16 +870,15 @@ quotedListWithOr :: [SDoc] -> SDoc -- [x,y,z] ==> `x', `y' or `z' quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs) quotedListWithOr xs = quotedList xs -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Printing numbers verbally} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} intWithCommas :: Integral a => a -> SDoc -- Prints a big integer with commas, eg 345,821 intWithCommas n @@ -982,16 +966,14 @@ plural _ = char 's' isOrAre :: [a] -> SDoc isOrAre [_] = ptext (sLit "is") isOrAre _ = ptext (sLit "are") -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Error handling} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" @@ -1043,5 +1025,3 @@ pprDebugAndThen dflags cont heading pretty_msg = cont (showSDocDump dflags doc) where doc = sep [heading, nest 2 pretty_msg] -\end{code} - diff --git a/compiler/utils/Outputable.lhs-boot b/compiler/utils/Outputable.hs-boot index e013307ef9..1c15a6982a 100644 --- a/compiler/utils/Outputable.lhs-boot +++ b/compiler/utils/Outputable.hs-boot @@ -1,7 +1,3 @@ - -\begin{code} module Outputable where data SDoc -\end{code} - diff --git a/compiler/utils/Pair.lhs b/compiler/utils/Pair.hs index 529ba669ea..f2d39de48e 100644 --- a/compiler/utils/Pair.lhs +++ b/compiler/utils/Pair.hs @@ -1,8 +1,8 @@ - +{- A simple homogeneous pair type with useful Functor, Applicative, and Traversable instances. +-} -\begin{code} {-# LANGUAGE CPP #-} module Pair ( Pair(..), unPair, toPair, swap ) where @@ -48,4 +48,3 @@ toPair (x,y) = Pair x y swap :: Pair a -> Pair a swap (Pair x y) = Pair y x -\end{code} diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.hs index 23bf01cafe..bfb9df3ad3 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.hs @@ -1,13 +1,13 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP Project, Glasgow University, 1992-2000 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + Defines basic functions for printing error messages. It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. +-} -\begin{code} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} module Panic ( @@ -305,5 +305,3 @@ popInterruptTargetThread = modifyMVar_ interruptTargetThread $ \tids -> return $! case tids of [] -> [] (_:ts) -> ts - -\end{code} diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.hs index 0357c8cfba..5e441838fc 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.hs @@ -1,15 +1,16 @@ -%********************************************************************************* -%* * -%* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * -%* * -%* based on "The Design of a Pretty-printing Library" * -%* in Advanced Functional Programming, * -%* Johan Jeuring and Erik Meijer (eds), LNCS 925 * -%* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * -%* * -%* Heavily modified by Simon Peyton Jones, Dec 96 * -%* * -%********************************************************************************* +{- +********************************************************************************* +* * +* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * +* * +* based on "The Design of a Pretty-printing Library" * +* in Advanced Functional Programming, * +* Johan Jeuring and Erik Meijer (eds), LNCS 925 * +* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * +* * +* Heavily modified by Simon Peyton Jones, Dec 96 * +* * +********************************************************************************* Version 3.0 28 May 1997 * Cured massive performance bug. If you write @@ -148,10 +149,8 @@ Relative to John's original paper, there are the following new features: 6. Numerous implementation tidy-ups Use of unboxed data types to speed up the implementation +-} - - -\begin{code} {-# LANGUAGE BangPatterns, CPP, MagicHash #-} module Pretty ( @@ -194,26 +193,20 @@ import GHC.Ptr ( Ptr(..) ) infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ -\end{code} - - -\begin{code} -- Disable ASSERT checks; they are expensive! #define LOCAL_ASSERT(x) -\end{code} - - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{The interface} -%* * -%********************************************************* +* * +********************************************************* The primitive @Doc@ values +-} -\begin{code} empty :: Doc isEmpty :: Doc -> Bool -- | Some text, but without any width. Use for non-printing text @@ -234,11 +227,9 @@ integer :: Integer -> Doc float :: Float -> Doc double :: Double -> Doc rational :: Rational -> Doc -\end{code} -Combining @Doc@ values +-- Combining @Doc@ values -\begin{code} (<>) :: Doc -> Doc -> Doc -- Beside hcat :: [Doc] -> Doc -- List version of <> (<+>) :: Doc -> Doc -> Doc -- Beside, separated by space @@ -254,18 +245,14 @@ fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep nest :: Int -> Doc -> Doc -- Nested -\end{code} -GHC-specific ones. +-- GHC-specific ones. -\begin{code} hang :: Doc -> Int -> Doc -> Doc punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] -\end{code} -Displaying @Doc@ values. +-- Displaying @Doc@ values. -\begin{code} instance Show Doc where showsPrec _ doc cont = showDocPlus PageMode 100 doc cont @@ -281,14 +268,13 @@ data Mode = PageMode -- Normal | ZigZagMode -- With zig-zag cuts | LeftMode -- No indentation, infinitely long lines | OneLineMode -- All on one line -\end{code} - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{The @Doc@ calculus} -%* * -%********************************************************* +* * +********************************************************* The @Doc@ combinators satisfy the following laws: \begin{verbatim} @@ -363,13 +349,13 @@ But it doesn't work, for if x=empty, we would have -%********************************************************* -%* * +********************************************************* +* * \subsection{Simple derived definitions} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} semi = char ';' colon = char ':' comma = char ',' @@ -411,18 +397,18 @@ punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es -\end{code} - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{The @Doc@ data type} -%* * -%********************************************************* +* * +********************************************************* A @Doc@ represents a {\em set} of layouts. A @Doc@ with no occurrences of @Union@ or @NoDoc@ represents just one layout. -\begin{code} +-} + data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x @@ -453,8 +439,8 @@ space_text :: TextDetails space_text = Chr ' ' nl_text :: TextDetails nl_text = Chr '\n' -\end{code} +{- Here are the invariants: \begin{itemize} \item @@ -486,8 +472,8 @@ is longer than the first line of any layout in the right argument. this invariant means that the right argument must have at least two lines. \end{itemize} +-} -\begin{code} -- Arg of a NilAbove is always an RDoc nilAbove_ :: Doc -> Doc nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p @@ -517,8 +503,8 @@ union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q) _ok (NilAbove _) = True _ok (Union _ _) = True _ok _ = False -\end{code} +{- Notice the difference between * NoDoc (no documents) * Empty (one empty document; no height and no width) @@ -527,13 +513,13 @@ Notice the difference between -%********************************************************* -%* * +********************************************************* +* * \subsection{@empty@, @text@, @nest@, @union@} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} empty = Empty isEmpty Empty = True @@ -574,16 +560,15 @@ mkNest k p = nest_ k p mkUnion :: Doc -> Doc -> Doc mkUnion Empty _ = Empty mkUnion p q = p `union_` q -\end{code} -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{Vertical composition @$$@} -%* * -%********************************************************* +* * +********************************************************* +-} - -\begin{code} p $$ q = Above p False q ($+$) :: Doc -> Doc -> Doc p $+$ q = Above p True q @@ -612,9 +597,7 @@ aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest Empty -> nilAboveNest g k1 q _ -> aboveNest p g k1 q aboveNest _ _ _ _ = panic "aboveNest: Unhandled case" -\end{code} -\begin{code} nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc -- Specification: text s <> nilaboveNest g k q -- = text s <> (text "" $g$ nest k q) @@ -626,16 +609,15 @@ nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline i = textBeside_ (Str (spaces k)) k q | otherwise -- Put them really above = nilAbove_ (mkNest k q) -\end{code} - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{Horizontal composition @<>@} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} p <> q = Beside p False q p <+> q = Beside p True q @@ -658,9 +640,7 @@ beside (TextBeside s sl p) g q = textBeside_ s sl $! rest rest = case p of Empty -> nilBeside g q _ -> beside p g q -\end{code} -\begin{code} nilBeside :: Bool -> RDoc -> RDoc -- Specification: text "" <> nilBeside g p -- = text "" <g> p @@ -669,15 +649,15 @@ nilBeside _ Empty = Empty -- Hence the text "" in the spec nilBeside g (Nest _ p) = nilBeside g p nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p | otherwise = p -\end{code} -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{Separate, @sep@, Hughes version} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} -- Specification: sep ps = oneLiner (hsep ps) -- `union` -- vcat ps @@ -722,15 +702,15 @@ sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) | otherwise = hcat ys sepNB g p k ys = sep1 g p k ys -\end{code} -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{@fill@} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} fsep = fill True fcat = fill False @@ -771,16 +751,15 @@ fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys | otherwise = k fillNB g p k ys = fill1 g p k ys -\end{code} - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{Selecting the best layout} -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} best :: Int -- Line length -> Int -- Ribbon length -> RDoc @@ -830,12 +809,12 @@ fits _ Empty = True fits _ (NilAbove _) = True fits n (TextBeside _ sl p) = fits (n -# sl) p fits _ _ = panic "fits: Unhandled case" -\end{code} +{- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. @first@ returns its first argument if it is non-empty, otherwise its second. +-} -\begin{code} first :: Doc -> Doc -> Doc first p q | nonEmptySet p = p | otherwise = q @@ -848,11 +827,9 @@ nonEmptySet (NilAbove _) = True -- NoDoc always in first line nonEmptySet (TextBeside _ _ p) = nonEmptySet p nonEmptySet (Nest _ p) = nonEmptySet p nonEmptySet _ = panic "nonEmptySet: Unhandled case" -\end{code} -@oneLiner@ returns the one-line members of the given set of @Doc@s. +-- @oneLiner@ returns the one-line members of the given set of @Doc@s. -\begin{code} oneLiner :: Doc -> Doc oneLiner NoDoc = NoDoc oneLiner Empty = Empty @@ -861,18 +838,15 @@ oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) oneLiner (Nest k p) = nest_ k (oneLiner p) oneLiner (p `Union` _) = oneLiner p oneLiner _ = panic "oneLiner: Unhandled case" -\end{code} - - -%********************************************************* -%* * +{- +********************************************************* +* * \subsection{Displaying the best layout} -%* * -%********************************************************* - +* * +********************************************************* +-} -\begin{code} showDocPlus :: Mode -> Int -> Doc -> String -> String showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc @@ -885,9 +859,6 @@ string_txt (Str s1) s2 = s1 ++ s2 string_txt (PStr s1) s2 = unpackFS s1 ++ s2 string_txt (ZStr s1) s2 = zString s1 ++ s2 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 -\end{code} - -\begin{code} fullRender OneLineMode _ _ txt end doc = lay (reduceDoc doc) @@ -977,9 +948,6 @@ spaces :: Int# -> String spaces n | n <=# _ILIT(0) = "" | otherwise = ' ' : spaces (n -# _ILIT(1)) -\end{code} - -\begin{code} printDoc :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc adds a newline to the end printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") @@ -1054,4 +1022,3 @@ layLeft b (TextBeside s _ p) = put b s >> layLeft b p put b (ZStr s) = bPutFZS b s put b (LStr s l) = bPutLitString b s l layLeft _ _ = panic "layLeft: Unhandled case" -\end{code} diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.hs index 9e6e6c1824..570282da57 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The University of Glasgow, 1997-2006 -% +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + Buffers for scanning string input stored in external arrays. +-} -\begin{code} {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised @@ -255,5 +255,3 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int | otherwise = case byteOff i of char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 - -\end{code} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.hs index f0f903522b..8f962d4f5e 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.hs @@ -1,7 +1,7 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1994-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + UniqFM: Specialised finite maps, for things with @Uniques@. @@ -18,8 +18,8 @@ The @UniqFM@ interface maps directly to Data.IntMap, only ``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. +-} -\begin{code} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} @@ -81,15 +81,15 @@ import Data.Data #if __GLASGOW_HASKELL__ < 709 import Data.Monoid #endif -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The signature of the module} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} emptyUFM :: UniqFM elt isNullUFM :: UniqFM elt -> Bool unitUFM :: Uniquable key => key -> elt -> UniqFM elt @@ -190,27 +190,26 @@ eltsUFM :: UniqFM elt -> [elt] ufmToSet_Directly :: UniqFM elt -> S.IntSet ufmToList :: UniqFM elt -> [(Unique, elt)] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Monoid interface} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} instance Monoid (UniqFM a) where mempty = emptyUFM mappend = plusUFM -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Implementation using ``Data.IntMap''} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newtype UniqFM ele = UFM (M.IntMap ele) deriving (Data, Eq, Foldable.Foldable, Functor, Traversable.Traversable, Typeable) @@ -294,15 +293,14 @@ joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v') (NoChange, _) -> (ch, joinmap) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Output-ery} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} instance Outputable a => Outputable (UniqFM a) where ppr ufm = pprUniqFM ppr ufm @@ -311,4 +309,3 @@ pprUniqFM ppr_elt ufm = brackets $ fsep $ punctuate comma $ [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt | (uq, elt) <- ufmToList ufm ] -\end{code} diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.hs index fae5ddabb6..5a82303157 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.hs @@ -1,14 +1,14 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1994-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + \section[UniqSet]{Specialised sets, for things with @Uniques@} Based on @UniqFMs@ (as you would expect). Basically, the things need to be in class @Uniquable@. +-} -\begin{code} module UniqSet ( -- * Unique set type UniqSet, -- type synonym for UniqFM a @@ -37,15 +37,14 @@ module UniqSet ( import UniqFM import Unique -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The signature of the module} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} emptyUniqSet :: UniqSet a unitUniqSet :: Uniquable a => a -> UniqSet a mkUniqSet :: Uniquable a => [a] -> UniqSet a @@ -74,15 +73,14 @@ sizeUniqSet :: UniqSet a -> Int isEmptyUniqSet :: UniqSet a -> Bool lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a uniqSetToList :: UniqSet a -> [a] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Implementation using ``UniqFM''} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} type UniqSet a = UniqFM a @@ -115,5 +113,3 @@ sizeUniqSet = sizeUFM isEmptyUniqSet = isNullUFM lookupUniqSet = lookupUFM uniqSetToList = eltsUFM - -\end{code} diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.hs index df293f091b..7d44a5004b 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.hs @@ -1,8 +1,5 @@ -% -% (c) The University of Glasgow 2006 -% +-- (c) The University of Glasgow 2006 -\begin{code} {-# LANGUAGE CPP #-} -- | Highly random utility functions @@ -133,13 +130,13 @@ import qualified Data.Set as Set import Data.Time infixr 9 `thenCmp` -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Is DEBUG on, are we on Windows, etc?} -%* * -%************************************************************************ +* * +************************************************************************ These booleans are global constants, set by CPP flags. They allow us to recompile a single module (this one) to change whether or not debug output @@ -149,8 +146,8 @@ It's important that the flags are literal constants (True/False). Then, with -0, tests of the flags in other modules will simplify to the correct branch of the conditional, thereby dropping debug code altogether when the flags are off. +-} -\begin{code} ghciSupported :: Bool #ifdef GHCI ghciSupported = True @@ -192,23 +189,21 @@ isDarwinHost = True #else isDarwinHost = False #endif -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{A for loop} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f -\end{code} -\begin{code} fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b thirdOf3 :: (a,b,c) -> c @@ -221,23 +216,21 @@ third3 f (a, b, c) = (a, b, f c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -\end{code} -\begin{code} firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) firstM f (x, y) = liftM (\x' -> (x', y)) (f x) first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-lists]{General list processing} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} filterOut :: (a->Bool) -> [a] -> [a] -- ^ Like filter, only it reverses the sense of the test filterOut _ [] = [] @@ -266,13 +259,13 @@ chkAppend :: [a] -> [a] -> [a] chkAppend xs ys | null ys = xs | otherwise = xs ++ ys -\end{code} +{- A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? +-} -\begin{code} zipEqual :: String -> [a] -> [b] -> [(a,b)] zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] @@ -302,17 +295,12 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif -\end{code} -\begin{code} -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys -\end{code} - -\begin{code} stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@ @@ -323,10 +311,7 @@ stretchZipWith p z f (x:xs) ys | otherwise = case ys of [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys -\end{code} - -\begin{code} mapFst :: (a->c) -> [(a,b)] -> [(c,b)] mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] @@ -364,9 +349,7 @@ mapAccumL2 f s1 s2 xs = (s1', s2', ys) where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of (s1', s2', y) -> ((s1', s2'), y)) (s1, s2) xs -\end{code} -\begin{code} nOfThem :: Int -> a -> [a] nOfThem n thing = replicate n thing @@ -451,11 +434,9 @@ only [a] = a only (a:_) = a #endif only _ = panic "Util: only" -\end{code} -Debugging/specialising versions of \tr{elem} and \tr{notElem} +-- Debugging/specialising versions of \tr{elem} and \tr{notElem} -\begin{code} isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool # ifndef DEBUG @@ -481,15 +462,15 @@ isn'tIn msg x ys (x `notElem` (y:ys)) | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys # endif /* DEBUG */ -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsubsection{Sort utils} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} sortWith :: Ord b => (a->b) -> [a] -> [a] sortWith get_key xs = sortBy (comparing get_key) xs @@ -499,17 +480,17 @@ minWith get_key xs = ASSERT( not (null xs) ) nubSort :: Ord a => [a] -> [a] nubSort = Set.toAscList . Set.fromList -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-transitive-closure]{Transitive closure} -%* * -%************************************************************************ +* * +************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. +-} -\begin{code} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate -> [a] @@ -525,17 +506,17 @@ transitiveClosure succ eq xs _ `is_in` [] = False x `is_in` (y:ys) | eq x y = True | otherwise = x `is_in` ys -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-accum]{Accumulating} -%* * -%************************************************************************ +* * +************************************************************************ A combination of foldl with zip. It works with equal length lists. +-} -\begin{code} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 _ z [] [] = z foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs @@ -547,21 +528,19 @@ all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False -\end{code} -Count the number of times a predicate is true +-- Count the number of times a predicate is true -\begin{code} count :: (a -> Bool) -> [a] -> Int count _ [] = 0 count p (x:xs) | p x = 1 + count p xs | otherwise = count p xs -\end{code} +{- @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: +-} -\begin{code} takeList :: [b] -> [a] -> [a] takeList [] _ = [] takeList (_:xs) ls = @@ -621,16 +600,15 @@ split c s = case rest of [] -> [chunk] _:rest -> chunk : split c rest where (chunk, rest) = break (==c) s -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-comparison]{Comparisons} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} isEqual :: Ordering -> Bool -- Often used in (isEqual (a `compare` b)) isEqual GT = False @@ -660,20 +638,18 @@ cmpList _ [] _ = LT cmpList _ _ [] = GT cmpList cmp (a:as) (b:bs) = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } -\end{code} -\begin{code} removeSpaces :: String -> String removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Edit distance} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing @@ -796,59 +772,49 @@ fuzzyLookup user_entered possibilites -- fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) mAX_RESULTS = 3 -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-pairs]{Pairs} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs -\end{code} -\begin{code} seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b -\end{code} -Global variables: +-- Global variables: -\begin{code} global :: a -> IORef a global a = unsafePerformIO (newIORef a) -\end{code} -\begin{code} consIORef :: IORef [a] -> a -> IO () consIORef var x = do atomicModifyIORef var (\xs -> (x:xs,())) -\end{code} -\begin{code} globalM :: IO a -> IORef a globalM ma = unsafePerformIO (ma >>= newIORef) -\end{code} -Module names: +-- Module names: -\begin{code} looksLikeModuleName :: String -> Bool looksLikeModuleName [] = False looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True go ('.':cs) = looksLikeModuleName cs go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs -\end{code} +{- Akin to @Prelude.words@, but acts like the Bourne shell, treating quoted strings as Haskell Strings, and also parses Haskell [String] syntax. +-} -\begin{code} getCmd :: String -> Either String -- Error (String, String) -- (Cmd, Rest) getCmd s = case break isSpace $ dropWhile isSpace s of @@ -890,12 +856,12 @@ toArgs str (arg, s'') -> case toArgs' s'' of Left err -> Left err Right args -> Right (arg : args) -\end{code} +{- -- ----------------------------------------------------------------------------- -- Floats +-} -\begin{code} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ r = do (n,d,s) <- readFix r @@ -1026,33 +992,31 @@ this `makeRelativeTo` that = directory </> thisFilename f (x : xs) (y : ys) | x == y = f xs ys f xs ys = replicate (length ys) ".." ++ xs -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-Data]{Utils for defining Data instances} -%* * -%************************************************************************ +* * +************************************************************************ These functions helps us to define Data instances for abstract types. +-} -\begin{code} abstractConstr :: String -> Constr abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix -\end{code} -\begin{code} abstractDataType :: String -> DataType abstractDataType n = mkDataType n [abstractConstr n] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-C]{Utils for printing C code} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} charToC :: Word8 -> String charToC w = case chr (fromIntegral w) of @@ -1064,15 +1028,15 @@ charToC w = chr (ord '0' + ord c `div` 64), chr (ord '0' + ord c `div` 8 `mod` 8), chr (ord '0' + ord c `mod` 8)] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[Utils-Hashing]{Utils for hashing} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A sample hash function for Strings. We keep multiplying by the -- golden ratio and adding. The implementation is: -- @@ -1131,5 +1095,3 @@ mulHi :: Int32 -> Int32 -> Int32 mulHi a b = fromIntegral (r `shiftR` 32) where r :: Int64 r = fromIntegral a * fromIntegral b -\end{code} - |