ghc/compiler/tests/typecheck/should_succeed/tc065.hs

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