2012-04-19 06:32:10 +00:00
|
|
|
module Replace (replace, depth) where
|
|
|
|
|
|
|
|
import Ast
|
2012-11-25 04:49:56 +00:00
|
|
|
import Control.Arrow ((***))
|
2012-04-28 06:57:11 +00:00
|
|
|
import Data.Set (singleton,empty,unions,member, Set)
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-04-28 06:57:11 +00:00
|
|
|
replace :: String -> Expr -> Expr -> Expr
|
2012-04-19 06:32:10 +00:00
|
|
|
replace y v expr =
|
|
|
|
let f = replace y v in
|
|
|
|
case expr of
|
|
|
|
Range e1 e2 -> Range (f e1) (f e2)
|
|
|
|
Access e x -> Access (f e) x
|
|
|
|
Binop op e1 e2 -> Binop op (f e1) (f e2)
|
|
|
|
App e1 e2 -> App (f e1) (f e2)
|
|
|
|
If e1 e2 e3 -> If (f e1) (f e2) (f e3)
|
2012-11-25 04:49:56 +00:00
|
|
|
Guard ps -> map (f *** f) ps
|
2012-04-19 06:32:10 +00:00
|
|
|
Lift e es -> Lift (f e) (map f es)
|
|
|
|
Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
|
|
|
|
Async e -> Async (f e)
|
2012-04-28 06:57:11 +00:00
|
|
|
Let defs e -> if y `elem` vs then Let defs e else Let (zip vs (map f es)) (f e)
|
2012-04-19 06:32:10 +00:00
|
|
|
where (vs,es) = unzip defs
|
|
|
|
Var x -> if x == y then v else Var x
|
|
|
|
Data name es -> Data name (map f es)
|
2012-04-28 06:57:11 +00:00
|
|
|
Case e cases -> Case (f e) $ map (caseReplace y v) cases
|
2012-04-19 06:32:10 +00:00
|
|
|
_ -> expr
|
|
|
|
|
2012-04-28 06:57:11 +00:00
|
|
|
caseReplace :: String -> Expr -> (Pattern, Expr) -> (Pattern, Expr)
|
|
|
|
caseReplace y v (p,e) =
|
|
|
|
if member y (patternVars p) then (p,e) else (p, replace y v e)
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-04-28 06:57:11 +00:00
|
|
|
patternVars :: Pattern -> Set String
|
|
|
|
patternVars pattern =
|
2012-04-19 06:32:10 +00:00
|
|
|
case pattern of
|
2012-04-28 06:57:11 +00:00
|
|
|
PData _ ps -> unions (map patternVars ps)
|
2012-04-19 06:32:10 +00:00
|
|
|
PVar x -> singleton x
|
2013-06-07 06:16:46 +00:00
|
|
|
PAsVar x p -> insert x (patternVars p)
|
2012-04-19 06:32:10 +00:00
|
|
|
PAnything -> empty
|
|
|
|
|
2012-04-28 06:57:11 +00:00
|
|
|
depth :: Expr -> Integer
|
2012-04-19 06:32:10 +00:00
|
|
|
depth = depth' 0
|
|
|
|
depth' d expr =
|
|
|
|
let f = depth' (d+1) in
|
|
|
|
case expr of
|
|
|
|
Range e1 e2 -> max (f e1) (f e2)
|
|
|
|
Access e x -> f e
|
|
|
|
Binop op e1 e2 -> max (f e1) (f e2)
|
|
|
|
Lambda x e -> f e
|
|
|
|
App e1 e2 -> max (f e1) (f e2)
|
|
|
|
If e1 e2 e3 -> maximum [f e1, f e2, f e3]
|
2012-11-25 04:49:56 +00:00
|
|
|
Guard ps -> maximum (map (uncurry max . f *** f) ps)
|
2012-04-19 06:32:10 +00:00
|
|
|
Lift e es -> maximum $ f e : map f es
|
|
|
|
Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
|
|
|
|
Async e -> f e
|
|
|
|
Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es
|
|
|
|
Data "Cons" es -> maximum $ map (depth' d) es
|
|
|
|
Data name es -> maximum $ 1 : map f es
|
|
|
|
Case e cases -> maximum $ f e : map (f . snd) cases
|
|
|
|
_ -> d
|