@@ -1,5 +1,7 @@
1+{-# LANGUAGE PatternGuards #-}
2+
13module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), CaseTree,
2− simpleCase, small, namesUsed, findCalls) where
4+ simpleCase, small, namesUsed, findCalls, findUsedArgs) where
35
46import Core.TT
57
@@ -68,7 +70,7 @@ namesUsed sc = nub $ nu' [] sc where
6870-- arguments
6971
7072findCalls :: SC -> [Name] -> [(Name, [[Name]])]
71−findCalls sc ign = nub $ nu' ign sc where
73+findCalls sc topargs = nub $ nu' topargs sc where
7274 nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)
7375 nu' ps (STerm t) = nub $ nut ps t
7476 nu' ps _ = []
@@ -77,32 +79,44 @@ findCalls sc ign = nub $ nu' ign sc where
7779 nua ps (ConstCase _ sc) = nu' ps sc
7880 nua ps (DefaultCase sc) = nu' ps sc
7981
80− nut ps (P _ n _) | n `elem` ps = []
82+ nut ps (P Ref n _) | n `elem` ps = []
8183 | otherwise = [(n, [])] -- tmp
82− nut ps (App f a) = nut ps f ++ nut ps a
84+ nut ps fn@(App f a)
85+ | (P Ref n _, args) <- unApply fn
86+ = if n `elem` ps then nut ps f ++ nut ps a
87+ else [(n, map argNames args)] ++ concatMap (nut ps) args
88+ | otherwise = nut ps f ++ nut ps a
8389 nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc
8490 nut ps (Bind n b sc) = nut (n:ps) sc
8591 nut ps _ = []
8692
87−-- Find directly used arguments (i.e. used but not in function calls)
88−{-
89−findUsedArgs :: SC -> [Name] -> [(Name, [[Name]])]
90−findUsedArgs sc ign = nub $ nu' ign sc where
91− nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)
92− nu' ps (STerm t) = nub $ nut ps t
93− nu' ps _ = []
94−
95− nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc)
96− nua ps (ConstCase _ sc) = nu' ps sc
97− nua ps (DefaultCase sc) = nu' ps sc
98−
99− nut ps (P _ n _) | n `elem` ps = []
100− | otherwise = [(n, [])] -- tmp
101− nut ps (App f a) = nut ps f ++ nut ps a
102− nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc
103− nut ps (Bind n b sc) = nut (n:ps) sc
104− nut ps _ = []
105−-}
93+ argNames tm = let ns = directUse tm in
94+ filter (\x -> x `elem` ns) topargs
95+
96+-- Find names which are used directly (i.e. not in a function call) in a term
97+
98+directUse :: Eq n => TT n -> [n]
99+directUse (P _ n _) = [n]
100+directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])
101+ ++ directUse t
102+directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])
103+directUse fn@(App f a)
104+ | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them
105+ | otherwise = nub $ directUse f ++ directUse a
106+directUse (Proj x i) = nub $ directUse x
107+directUse _ = []
108+
109+-- Find all directly used arguments (i.e. used but not in function calls)
110+
111+findUsedArgs :: SC -> [Name] -> [Name]
112+findUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nub $ nu' sc) where
113+ nu' (Case n alts) = n : concatMap nua alts
114+ nu' (STerm t) = directUse t
115+ nu' _ = []
116+
117+ nua (ConCase n i args sc) = nu' sc
118+ nua (ConstCase _ sc) = nu' sc
119+ nua (DefaultCase sc) = nu' sc
106120
107121simpleCase :: Bool -> Bool -> Bool -> FC -> [([Name], Term, Term)] -> TC CaseDef
108122simpleCase tc cover proj fc []