blob: fa22a175cd66e82897de8774bb62fcdc60e44d7c (
plain)
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
|
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"))))
)
)
)
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
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
subVarsCExp :: ([String], CExpF a) -> CExpF ([String], a)
subVarsCExp = undefined
|
