ghc/tests/typecheck/should_compile/tc065.hs

   1 module ShouldSucceed where
   2
   3 -- import TheUtils
   4 import Set
   5 import List (partition )
   6
   7 data Digraph vertex = MkDigraph [vertex]
   8
   9 type Edge  vertex = (vertex, vertex)
  10 type Cycle vertex = [vertex]
  11
  12 mkDigraph = MkDigraph
  13
  14 stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]]
  15 stronglyConnComp es vs
  16   = snd (span_tree (new_range reversed_edges)
  17                     ([],[])
  18                    ( snd (dfs (new_range es) ([],[]) vs) )
  19          )
  20  where
  21    reversed_edges = map swap es
  22
  23    swap :: Edge v -> Edge v
  24    swap (x,y) = (y, x)
  25
  26    new_range    []       w = []
  27    new_range ((x,y):xys) w
  28         = if x==w
  29           then (y : (new_range xys w))
  30           else (new_range xys w)
  31
  32    span_tree r (vs,ns) []   = (vs,ns)
  33    span_tree r (vs,ns) (x:xs)
  34         | x `elem` vs = span_tree r (vs,ns) xs
  35         | otherwise = span_tree r (vs',(x:ns'):ns) xs
  36           where
  37             (vs',ns') = dfs r (x:vs,[]) (r x)
  38
  39 dfs r (vs,ns)   []   = (vs,ns)
  40 dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
  41                      | otherwise = dfs r (vs',(x:ns')++ns) xs
  42                                    where
  43                                      (vs',ns') = dfs r (x:vs,[]) (r x)
  44
  45
  46 isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool
  47 isCyclic edges [v] = (v,v) `elem` edges
  48 isCyclic edges vs = True
  49
  50
  51 topSort :: (Eq vertex) => [Edge vertex] -> [vertex]
  52               -> MaybeErr [vertex] [[vertex]]
  53
  54
  55 topSort edges vertices
  56  = case cycles of
  57         [] -> Succeeded [v | [v] <- singletons]
  58         _  -> Failed cycles
  59    where
  60    sccs = stronglyConnComp edges vertices
  61    (cycles, singletons) = partition (isCyclic edges) sccs
  62
  63
  64 type FlattenedDependencyInfo vertex name code
  65    = [(vertex, Set name, Set name, code)]
  66
  67 mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex]
  68 mkVertices info = [ vertex | (vertex,_,_,_) <- info]
  69
  70 mkEdges :: (Eq vertex, Ord name) =>
  71             [vertex]
  72          -> FlattenedDependencyInfo vertex name code
  73          -> [Edge vertex]
  74
  75 mkEdges vertices flat_info
  76  = [ (source_vertex, target_vertex)
  77    | (source_vertex, _, used_names, _) <- flat_info,
  78      target_name   <- setToList used_names,
  79      target_vertex <- vertices_defining target_name flat_info
  80    ]
  81  where
  82    vertices_defining name flat_info
  83     = [ vertex |  (vertex, names_defined, _, _) <- flat_info,
  84                 name `elementOf` names_defined
  85       ]
  86
  87 lookupVertex :: (Eq vertex, Ord name) =>
  88                  FlattenedDependencyInfo vertex name code
  89               -> vertex
  90               -> code
  91
  92 lookupVertex flat_info vertex
  93  = head code_list
  94  where
  95    code_list = [ code | (vertex',_,_,code) <- flat_info, vertex == vertex']
  96
  97
  98 isRecursiveCycle :: (Eq vertex) => Cycle vertex -> [Edge vertex] -> Bool
  99 isRecursiveCycle [vertex] edges = (vertex, vertex) `elem` edges
 100 isRecursiveCycle cycle    edges = True
 101
 102
 103
 104 -- may go to TheUtils
 105
 106 data MaybeErr a b = Succeeded a | Failed b
 107