FlatCurryDependency.curry 2.58 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
--- A few base functions for analysing type dependencies in FlatCurry programs.
---
--- @author Heiko Hoffmann, Michael Hanus
Michael Hanus's avatar
Michael Hanus committed
5
--- @version Junes 2017
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
-----------------------------------------------------------------------------

module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where

import FlatCurry.Types
import List
import SetRBT

--- Return the type constructors occurring in a type declaration.
dependsDirectlyOnTypes :: TypeDecl -> [QName]

dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
  nub (concatMap (\ (Cons _ _ _ typeExprs) -> concatMap tconsOf typeExprs)
                 consDeclList)

dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)


tconsOf :: TypeExpr -> [(String,String)]
tconsOf (TVar _) = []
tconsOf (FuncType a b) =  tconsOf a ++ tconsOf b
Michael Hanus's avatar
Michael Hanus committed
27
tconsOf (TCons qName texps) = qName : concatMap tconsOf texps
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70


-----------------------------------------------------------------------------
-- list of direct dependencies for a function
callsDirectly :: FuncDecl -> [QName]
callsDirectly fun = setRBT2list (snd (directlyDependent fun))

-- set of direct dependencies for a function
directlyDependent :: FuncDecl -> (QName,SetRBT QName)
directlyDependent (Func f _ _ _ (Rule _ e))   = (f,funcSetOfExpr e)
directlyDependent (Func f _ _ _ (External _)) = (f,emptySet)

-- Gets the set of all functions (including partially applied functions)
-- called in an expression:
funcSetOfExpr :: Expr -> SetRBT QName
funcSetOfExpr (Var _) = emptySet
funcSetOfExpr (Lit _) = emptySet
funcSetOfExpr (Comb ct f es) =
  if isConstructorComb ct then unionMap funcSetOfExpr es
                          else insertRBT f (unionMap funcSetOfExpr es)
funcSetOfExpr (Free _ e) = funcSetOfExpr e
funcSetOfExpr (Let bs e) = unionRBT (unionMap (funcSetOfExpr . snd) bs)
                                    (funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = unionRBT (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e)
                                       (unionMap funcSetOfBranch bs)
 where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
funcSetOfExpr (Typed e _) = funcSetOfExpr e

isConstructorComb :: CombType -> Bool
isConstructorComb ct = case ct of
  ConsCall       -> True
  ConsPartCall _ -> True
  _              -> False

unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f

emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName

leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2)