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
|
module Lift where
import Data.Functor.Foldable
import Data.List
import Types
converge f a = let a' = f a in if a' == a then a else converge f a'
factorial :: AExp
factorial =
( Lam
["n"]
( Let
"m"
(Call "factorial" [(ASub (Ident "n") (Number 1))])
( If
(ALt (Ident "n") (Number 2))
(FC (Atom (Number 1)))
(FC (Atom (AMul (Ident "m") (Ident "n"))))
)
)
)
three :: CExp
three =
( Let
"n"
(Atom (Number 1))
( Let
"n"
(Atom (AAdd (Ident "n") (Number 1)))
( Let
"n"
(Atom (AAdd (Ident "n") (Number 1)))
(FC (Atom (Ident "n")))
)
)
)
liftArgs :: AExp -> AExp
liftArgs lam@(Lam args body) = Lam (args ++ cata findVarsAExp lam) body
liftArgs rest = rest
-- | F-Algebras to find free variables
findVars :: CExpF [String] -> [String]
findVars (LetF ident fc rest) = converge (\\ [ident]) $ rest ++ (findVarsFC fc)
findVars (IfF cond t e) = t ++ e ++ (cata findVarsAExp cond)
findVars (FCF fc) = findVarsFC fc
findVarsFC :: Funcall -> [String]
findVarsFC (Atom aexp) = cata findVarsAExp aexp
findVarsFC (Call id args) = id : (args >>= cata findVarsAExp)
findVarsAExp :: AExpF [String] -> [String]
findVarsAExp (IdentF ns) = [ns]
findVarsAExp (LamF args cexp) = converge (\\ args) (fold findVars cexp)
findVarsAExp def = foldMap id def
-- replacing free variables with a new one if it matches the argument
compareNames n m = if n == m then n ++ "_" else n
-- | replace bound variables in AExps
-- >>> hoist (replaceVarsAExp "n") factorial
replaceVarsAExp :: String -> AExpF a -> AExpF a
replaceVarsAExp n (IdentF m) = IdentF $ compareNames m n
replaceVarsAExp n (LamF args body) =
LamF
(fmap (\x -> if x == n then x ++ "_" else x) args)
(cata replaceVarsCExp body n)
replaceVarsAExp _ rest = rest
-- | replace bound variables in CExps
replaceVarsCExp :: CExpF (String -> CExp) -> String -> CExp
replaceVarsCExp (LetF name fc restf) = do
env <- id
rest <- restf
let newName = compareNames name env
return $ Let newName (replaceVarsFC env fc) rest
replaceVarsCExp (IfF cond thenF elseF) = do
thenPart <- thenF
elsePart <- elseF
env <- id
return $ If (hoist (replaceVarsAExp env) cond) thenPart elsePart
replaceVarsCExp (FCF fc) = do
env <- id
return $ FC (replaceVarsFC env fc)
-- | replace bound variables in Function calls
replaceVarsFC :: String -> Funcall -> Funcall
replaceVarsFC n (Atom aexp) = Atom $ hoist (replaceVarsAExp n) aexp
replaceVarsFC n (Call name args) =
Call
(compareNames name n)
$ fmap (hoist (replaceVarsAExp n)) args
subVarsAExp :: ([String], AExpF a) -> AExpF ([String], a)
subVarsAExp (env, LamF args body) =
let
toReplace = intersect env args
newArgs = fmap (\x -> if x `elem` toReplace then x ++ "_" else x) args
newBody = foldl (cata replaceVarsCExp) body toReplace
in
LamF newArgs (cotransverse subVarsCExp (newArgs ++ env, [], newBody))
subVarsAExp (env, rest) = fmap (env,) rest
{- | cotransverse of a complex expression. The first string list represents
| bound variables, the second one a queue of variables to be replaced
-}
subVarsCExp :: ([String], [String], CExpF a) -> CExpF ([String], [String], a)
subVarsCExp (env, queue, LetF name fc rest) =
let
(newName, oldNames) =
foldr
(\m (n, ns) -> if n == m then (n ++ "_", n : ns) else (n, ns)) -- repeatedly replace variables in the function call
(name, [])
queue -- make sure to do oldest first!
newFC = foldr replaceVarsFC fc $ oldNames \\ [newName]
in
LetF newName newFC (if name `elem` env then (env, newName : queue, rest) else (name : env, name : queue, rest))
subVarsCExp (env, queue, IfF cond thenPart elsePart) =
IfF
(foldr (\x c -> hoist (replaceVarsAExp x) c) cond queue)
(env, queue, thenPart)
(env, queue, elsePart)
subVarsCExp (env, queue, FCF fc) = FCF $ foldr replaceVarsFC fc queue
unsafeCotransverse ::
(Corecursive t, Recursive a, Functor f) =>
(f (Base a a) -> Base t (f a)) ->
f a ->
t
unsafeCotransverse n = ana (n . fmap project)
subVarsCExp' :: ([String], CExpF CExp) -> CExpF ([String], CExp)
subVarsCExp' (env, LetF name fc body)
| name `elem` env =
let
newName = name ++ "_"
newFC = replaceVarsFC newName fc
newBody = cata replaceVarsCExp body name
in
LetF newName newFC (newName : env, newBody)
| otherwise = LetF name fc (name : env, body)
subVarsCExp' (env, rest) = fmap (env,) rest
substitute :: CExp -> CExp
substitute = unsafeCotransverse subVarsCExp' . ([],)
|
