Control Flow Analysis solver for a simple functional language (Yes, my Haskell sucks, I'm out of practice!)

cfa.hs

import Data.Set (Set, unions, union, insert, empty, singleton, foldl, member, isSubsetOf)
import Data.Maybe (fromMaybe)
import Text.Show.Pretty (ppShow)

class ShowNolabel a where
  showNolabel :: a -> String

data Expr = Expr {term :: Term, label :: Integer}
  deriving (Eq, Ord)
instance Show Expr where
  show (Expr t l) = "(" ++ show t ++ ")^{" ++ show l ++ "}"
instance ShowNolabel Expr where
  showNolabel (Expr t l) = "(" ++ showNolabel t ++ ")"

data Term = Id String | FT Function | App Expr Expr | Cond Expr Expr Expr
  | Let String Expr Expr
  deriving (Eq, Ord)
instance Show Term where
  show (Id x) = x
  show (FT f) = show f
  show (App a b) = show a ++ " " ++ show b
  show (Cond a b c) = "if " ++ show a ++ " then " ++ show b ++ " else " ++ show c
  show (Let x a b) = "let " ++ x ++ "= " ++ show a ++ " in " ++ show b
instance ShowNolabel Term where
  showNolabel (FT f) = showNolabel f
  showNolabel (App a b) = showNolabel a ++ " " ++ showNolabel b
  showNolabel (Cond a b c) = "if " ++ showNolabel a ++ " then " ++ showNolabel b ++ " else " ++ showNolabel c
  showNolabel (Let x a b) = "let " ++ x ++ "= " ++ showNolabel a ++ " in " ++ showNolabel b
  showNolabel t = show t

data Function = F String Expr
  deriving (Eq, Ord)
instance Show Function where
  show (F x e) = "fn " ++ x ++ " => " ++ show e
instance ShowNolabel Function where
  showNolabel (F x e) = "fn " ++ x ++ " => " ++ showNolabel e

data CSets = R String | C Integer | FC Function
  deriving (Eq, Ord)
instance Show CSets where
  show (R s) = "r(" ++ s ++ ")"
  show (C i) = "C(" ++ show i ++ ")"
  show (FC f) = "{" ++ show f ++ "}"

data Constraint =  Subset CSets CSets | Implies Constraint Constraint
  deriving (Eq, Ord)
instance Show Constraint where
  show (Subset a b)  = show a ++ "⊆" ++ show b
  show (Implies a b) = show a ++ "⇒" ++ show b

fnse :: Expr -> [ Function ]
fnse = fns.term

fns :: Term -> [ Function ]
fns (App e1 e2)     = concatMap fnse [e1, e2]
fns (Cond e0 e1 e2) = concatMap fnse [e0, e1, e2]
fns (Let _ e1 e2)   = concatMap fnse [e1, e2]
fns (FT f@(F _ e))  = f : (fnse e)
fns _               = []

cstar :: Expr -> Set Constraint
cstar e = cstar' e
  where
    funcTerms = fnse e
    cstar' (Expr (Id x) l)
      = singleton (Subset (R x) (C l))
    cstar' (Expr (FT f@(F _ e)) l)
      = union (cstar' e) (singleton (Subset (FC f) (C l)))
    cstar' (Expr (Cond e0 e1 e2) l)
      = unions [ cstar' e0, cstar' e1, cstar' e2
               , singleton (Subset (C (label e1)) (C l))
               , singleton (Subset (C (label e2)) (C l))
               ]
    cstar' (Expr (Let x e1 e2) l)
      = unions [ cstar' e1, cstar' e2
               , singleton (Subset (C (label e1)) (R x))
               , singleton (Subset (C (label e2)) (C l))
               ]
    cstar' (Expr (App e1 e2) l)
      = unions ([ cstar' e1, cstar' e2 ]
        ++ map (funcTermConstr l (label e1) (label e2)) funcTerms)
    funcTermConstr :: Integer -> Integer -> Integer -> Function -> Set Constraint
    funcTermConstr l l1 l2 f@(F x exp) = union
      (singleton (Implies (Subset (FC f) (C l1)) (Subset (C l2) (R x))))
      (singleton (Implies (Subset (FC f) (C l1)) (Subset (C (label exp)) (C l))))

fnx = Expr (FT (F "x" (Expr (Id "x") 1))) 2
fny = Expr (FT (F "y" (Expr (App (Expr (Id "y") 3) (Expr (Id "y") 4)) 5))) 6
fnz = Expr (FT (F "z" (Expr (App (Expr (Id "z") 8) (Expr (Id "z") 9)) 10))) 11
expr = Expr (App (Expr (App fnx fny) 7) fnz) 12

idx = Expr (FT (F "x" (Expr (Id "x") 1))) 2
idy = Expr (FT (F "y" (Expr (Id "y") 3))) 4
idt = Expr (App idx idy) 5

type Stack = [CSets]
type Data = [(CSets, Set Function)]
type Edges = [(CSets, Set Constraint)]

solve :: Set Constraint -> Data
solve = iterateWDE . buildInitWDE

buildInitWDE :: Set Constraint -> (Stack, Data, Edges)
buildInitWDE = Data.Set.foldl buildInitWDE' ([], [], [])
  where
    buildInitWDE' (w,d,e) (Subset (FC f) p)
      = addWDE (w,d,e) p (singleton f)
    buildInitWDE' (w,d,e) cc@(Subset p1 p2)
      = (w, d, insertUpdate (p1,cc) e)
    buildInitWDE' (w,d,e) cc@(Implies (Subset _ p) (Subset p1 p2))
      = (w, d, insertUpdate (p1,cc) (insertUpdate (p,cc) e))

iterateWDE :: (Stack, Data, Edges) -> Data
iterateWDE ([],d,_)  = d
iterateWDE (q:w,d,e) = iterateWDE $ Data.Set.foldl iterateWDE' (w,d,e) cc
  where
    cc = lookupSet q e
    iterateWDE' (w,d,e) (Subset p1 p2)
      = addWDE (w,d,e) p2 (lookupSet p1 d)
    iterateWDE' (w,d,e) (Implies (Subset (FC t) p) (Subset p1 p2))
      | member t (lookupSet p d) = addWDE (w,d,e) p2 (lookupSet p1 d) 
      | otherwise                = (w,d,e)

addWDE :: (Stack, Data, Edges) -> CSets -> Set Function -> (Stack, Data, Edges)
addWDE (w,d,e) q upd
  | not $ isSubsetOf upd (lookupSet q d) = (q:w, unionUpdate (q,upd) d, e)
  | otherwise                            = (w,d,e)

lookupSet :: (Eq a, Ord b) => a -> [(a, Set b)] -> Set b
lookupSet a map = fromMaybe empty (lookup a map)

genericUpdate :: (Eq a, Ord b) => (c -> Set b -> Set b) -> (a, c) ->
  [(a, Set b)] -> [(a, Set b)]
genericUpdate f (a,b) map
  = replace (a, (f b (lookupSet a map))) map

unionUpdate :: (Eq a, Ord b) => (a, Set b) -> [(a, Set b)] -> [(a, Set b)]
unionUpdate = genericUpdate union

insertUpdate :: (Eq a, Ord b) => (a, b) -> [(a, Set b)] -> [(a, Set b)]
insertUpdate = genericUpdate insert

replace :: (Eq a) => (a, b) -> [(a, b)] -> [(a, b)]
replace elem []           = [elem]
replace elem@(idx,set) ls = top ++ elem : tail' bottom
  where
    (top, bottom) = span (((/=) idx).fst) ls
    tail' []      = []
    tail' (x:xs)  = xs