1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
module FlatCurry.ElimNewtype
( elimNewtypeInProg, elimNewtype )
where
import Data.List ( isPrefixOf )
import FlatCurry.Files ( readFlatCurryInt )
import FlatCurry.Goodies ( progImports, progTypes )
import FlatCurry.Types
elimNewtypeInProg :: Prog -> IO Prog
elimNewtypeInProg prog = do
impints <- mapM readFlatCurryInt (progImports prog)
return $ elimNewtype impints prog
elimNewtype :: [Prog] -> Prog -> Prog
elimNewtype impprogs prog@(Prog mname imps tdecls fdecls ops) =
if null nti
then prog
else Prog mname imps (map replaceNewtypeDecl tdecls)
(map (elimNewtypeInFunc nti) fdecls) ops
where
nti = newtypesOfProg (tdecls ++ concatMap progTypes impprogs)
replaceNewtypeDecl :: TypeDecl -> TypeDecl
replaceNewtypeDecl td = case td of
TypeNew tc tvis tvs (NewCons ct cvis te)
-> Type tc tvis tvs [Cons ct 1 cvis [te]]
_ -> td
elimNewtypeInFunc :: [NewtypeInfo] -> FuncDecl -> FuncDecl
elimNewtypeInFunc _ fd@(Func _ _ _ _ (External _)) = fd
elimNewtypeInFunc nti fd@(Func qf ar vis ftype (Rule args rhs)) =
if isClassInstanceOp qf
then fd
else Func qf ar vis (elimType ftype) (Rule args (elimExp rhs))
where
elimType te = case te of
TVar _ -> te
FuncType t1 t2 -> FuncType (elimType t1) (elimType t2)
TCons tc tes -> elimTCons tc (map elimType tes)
ForallType tvs fte -> ForallType tvs (elimType fte)
elimTCons tc tes =
maybe (TCons tc tes)
(\ (tvs,_,ntexp) -> substTVarsInTExp (zip tvs tes) ntexp)
(lookup tc nti)
elimExp exp = case exp of
Var _ -> exp
Lit _ -> exp
Comb ct qn es -> elimComb ct qn (map elimExp es)
Let bs e -> Let (map (\ (v,be) -> (v, elimExp be)) bs) (elimExp e)
Free vs e -> Free vs (elimExp e)
Or e1 e2 -> Or (elimExp e1) (elimExp e2)
Case ct ce bs -> elimCase ct (elimExp ce)
(map (\ (Branch pt be) -> Branch pt (elimExp be)) bs)
Typed e t -> Typed (elimExp e) t
elimComb ct qn es = case ct of
ConsCall | length es == 1 && isNewCons qn
-> head es
ConsPartCall 1 | null es && isNewCons qn
-> Comb (FuncPartCall 1) ("Prelude","id") []
_ -> Comb ct qn es
elimCase ct ce bs = case bs of
[Branch (Pattern qn [v]) be] | isNewCons qn
-> case ce of Var cv -> substVarInExp v cv be
_ -> Let [(v,ce)] be
_ -> Case ct ce bs
isNewCons qn = qn `elem` map (\ (_,(_,nc,_)) -> nc) nti
substTVarsInTExp :: [(TVarIndex,TypeExpr)] -> TypeExpr -> TypeExpr
substTVarsInTExp tvtexps te = subst te
where
subst texp = case texp of
TVar v -> maybe texp id (lookup v tvtexps)
FuncType t1 t2 -> FuncType (subst t1) (subst t2)
TCons tc tes -> TCons tc (map subst tes)
ForallType tvs fte -> ForallType tvs (subst fte)
substVarInExp :: VarIndex -> VarIndex -> Expr -> Expr
substVarInExp x y e0 = subst e0
where
subst exp = case exp of
Var v -> Var (if v == x then y else v)
Lit _ -> exp
Comb ct qn es -> Comb ct qn (map subst es)
Let bs e -> Let (map (\ (v,be) -> (v, subst be)) bs) (subst e)
Free vs e -> Free vs (subst e)
Or e1 e2 -> Or (subst e1) (subst e2)
Case ct ce bs -> Case ct (subst ce)
(map (\ (Branch pt be) -> Branch pt (subst be)) bs)
Typed e t -> Typed (subst e) t
type NewtypeInfo = (QName,([TVarIndex],QName,TypeExpr))
newtypesOfProg :: [TypeDecl] -> [NewtypeInfo]
newtypesOfProg = concatMap ntOfTypeDecl
where
ntOfTypeDecl (Type _ _ _ _ ) = []
ntOfTypeDecl (TypeSyn _ _ _ _ ) = []
ntOfTypeDecl (TypeNew tc _ tvs (NewCons ct _ te)) =
[(tc, (map fst tvs, ct, te))]
isNewtypeDecl :: TypeDecl -> Bool
isNewtypeDecl td = case td of TypeNew _ _ _ _ -> True
_ -> False
isClassInstanceOp :: QName -> Bool
isClassInstanceOp (_,f) = "_inst#" `isPrefixOf` f
|