ref: 15be3d6e17a2cf75c491cf1624fa6441bf94a3dd
parent: d52fbaee2874efaae17542bdc1e2be46339e10fd
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Sep 16 11:33:23 EDT 2023
Fix bug in freeVars
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.3
-812
-(($A :0 ((_616 _569) (($B ((($S' ($C ((($C' ($S' _616)) (($B ($C _2)) _555)) (($B ($B (_616 _644))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _617)) ((($C' $B) (($B _709) (($B _634) ((($C' _747) _8) 0)))) (($B (_709 _637)) (($B (_650 "top level defns: ")) _598)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _617)) ((($C' $B) (($B _709) (($B _634) ((($C' _747) _8) 1)))) (_633 ($T (($B ($B (_709 _637))) ((($C' $B) (($B _650) ((($C' _650) _560) " = "))) _387)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _617))) ((($C' $B) ($B' (($B _709) (($B _639) _11)))) (($C' _650) ((($C' _650) (($B (_650 _1)) _598)) (($O 10) $K)))))) (($B ($B (_616 _644))) ((($C' $B) ($B' (($B _709) (($B _634) ((($C' _747) _8) 0))))) (($B ($B (_709 _637))) ((($C' ($C' _650)) (($B ($B (_650 "final pass "))) (($B ($B (_611 6))) (($B ($B _598)) _741)))) "ms"))))))) _3)))) _595))) (($B (($C' $C) (($B ($C _655)) _387))) (($C _668) (_685 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _650)))) (($B ($C' ($C' _650))) ((($C' ($C' ($C' _650))) (($B (($C' $B) (($B _650) ((($C' _650) (($B (_650 "(($A :")) _598)) (($O 32) $K))))) ($B _387))) ") "))) (($O 41) $K)))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _364)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _709) (($B _706) (($B (_709 _756)) (($B (_650 "main: findIdent: ")) _560))))) (($C' _588) _557)))) (($B ($B _592)) (($B (($C' _652) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _557))) $K)))))) (($C _668) (_685 0)))))) (($B (_709 _363)) (($B (_709 _555)) (($B (_650 (($O 95) $K))) _598)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _667) (_654 (_609 "-v")))) ((_684 _609) "-r"))) (($B (_648 (($O 46) $K))) (($B _708) (_653 ((_672 _732) "-i")))))) (($B (_709 _679)) ((($C' _650) (($B _708) (_653 ((_672 _732) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _743) _667) 1)) (_756 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _679)) (_654 ((_710 _752) ((_710 (_609 (($O 45) $K))) (_665 1))))))) (_675 ((_710 _752) (_609 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _616)) _16) (($B ($B ($B (_616 _644)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _617) (($B (_709 _635)) (($B (_709 (_666 1000000))) _187)))))) (($B ($B ($B ($B (_616 _644))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _617))) ((($C' $B) ($B' (($B _709) (($B _634) ((($C' _747) _8) 0))))) (($B ($B (_709 _637))) ((($C' ($C' _650)) (($B ($B (_650 "combinator conversion "))) (($B ($B (_611 6))) (($B ($B _598)) _741)))) "ms")))))) (($B ($B _618)) (($B $P) (($C _562) (_555 "main")))))))) (_652 ($T ((($C' ($C' $O)) ((($C' $B) $P) _390)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_616 _569)))) (($B ($B ($B (($C' _570) ((($C' _736) (($B _667) (_675 ((_710 _752) (_609 "--"))))) 1))))) (($B ($B ($B (_709 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _546))) (($C' ($C' _652)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _709) (($B _706) (($B (_709 _756)) (($B (_650 "not found ")) _560))))) ($C _547))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _389))) (($B (_709 (_706 (_756 "primlookup")))) (($C (_690 _609)) _5)))) $K))) (_756 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O
\ No newline at end of file
+814
+(($A :0 ((_616 _569) (($B ((($S' ($C ((($C' ($S' _616)) (($B ($C _2)) _555)) (($B ($B (_616 _644))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _617)) ((($C' $B) (($B _711) (($B _634) ((($C' _749) _8) 0)))) (($B (_711 _637)) (($B (_650 "top level defns: ")) _598)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _617)) ((($C' $B) (($B _711) (($B _634) ((($C' _749) _8) 1)))) (_633 ($T (($B ($B (_711 _637))) ((($C' $B) (($B _650) ((($C' _650) _560) " = "))) _387)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _617))) ((($C' $B) ($B' (($B _711) (($B _639) _11)))) (($C' _650) ((($C' _650) (($B (_650 _1)) _598)) (($O 10) $K)))))) (($B ($B (_616 _644))) ((($C' $B) ($B' (($B _711) (($B _634) ((($C' _749) _8) 0))))) (($B ($B (_711 _637))) ((($C' ($C' _650)) (($B ($B (_650 "final pass "))) (($B ($B (_611 6))) (($B ($B _598)) _743)))) "ms"))))))) _3)))) _595))) (($B (($C' $C) (($B ($C _655)) _387))) (($C _668) (_685 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _650)))) (($B ($C' ($C' _650))) ((($C' ($C' ($C' _650))) (($B (($C' $B) (($B _650) ((($C' _650) (($B (_650 "(($A :")) _598)) (($O 32) $K))))) ($B _387))) ") "))) (($O 41) $K)))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _364)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _711) (($B _708) (($B (_711 _758)) (($B (_650 "main: findIdent: ")) _560))))) (($C' _588) _557)))) (($B ($B _592)) (($B (($C' _652) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _557))) $K)))))) (($C _668) (_685 0)))))) (($B (_711 _363)) (($B (_711 _555)) (($B (_650 (($O 95) $K))) _598)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _667) (_654 (_609 "-v")))) ((_684 _609) "-r"))) (($B (_648 (($O 46) $K))) (($B _710) (_653 ((_672 _734) "-i")))))) (($B (_711 _679)) ((($C' _650) (($B _710) (_653 ((_672 _734) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _745) _667) 1)) (_758 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _679)) (_654 ((_712 _754) ((_712 (_609 (($O 45) $K))) (_665 1))))))) (_675 ((_712 _754) (_609 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _616)) _16) (($B ($B ($B (_616 _644)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _617) (($B (_711 _635)) (($B (_711 (_666 1000000))) _187)))))) (($B ($B ($B ($B (_616 _644))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _617))) ((($C' $B) ($B' (($B _711) (($B _634) ((($C' _749) _8) 0))))) (($B ($B (_711 _637))) ((($C' ($C' _650)) (($B ($B (_650 "combinator conversion "))) (($B ($B (_611 6))) (($B ($B _598)) _743)))) "ms")))))) (($B ($B _618)) (($B $P) (($C _562) (_555 "main")))))))) (_652 ($T ((($C' ($C' $O)) ((($C' $B) $P) _390)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_616 _569)))) (($B ($B ($B (($C' _570) ((($C' _738) (($B _667) (_675 ((_712 _754) (_609 "--"))))) 1))))) (($B ($B ($B (_711 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _546))) (($C' ($C' _652)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _711) (($B _708) (($B (_711 _758)) (($B (_650 "not found ")) _560))))) ($C _547))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _389))) (($B (_711 (_708 (_758 "primlookup")))) (($C (_690 _609)) _5)))) $K))) (_758 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O
\ No newline at end of file
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -232,6 +232,10 @@
deleteBy _ _ [] = []
deleteBy eq x (y:ys) = if eq x y then ys else y : deleteBy eq x ys
+deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]
+deleteAllBy _ _ [] = []
+deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys
+
nubBy :: forall a . (a -> a -> Bool) -> [a] -> [a]
nubBy _ [] = []
nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
@@ -247,6 +251,9 @@
deleteFirstsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy eq = foldl (flip (deleteBy eq))
+
+deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteAllsBy eq = foldl (flip (deleteAllBy eq))
infixl 9 !!
(!!) :: forall a . Int -> [a] -> a
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -145,3 +145,10 @@
sortLE _ [] = []
sortLE le (x:xs) = sortLE le lt ++ (x : sortLE le ge)
where (ge, lt) = partition (le x) xs
+
+deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]
+deleteAllBy _ _ [] = []
+deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys
+
+deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteAllsBy eq = foldl (flip (deleteAllBy eq))
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -205,7 +205,7 @@
apps f = foldl App f
newVars :: String -> [Ident] -> [Ident]
-newVars s is = deleteFirstsBy eqIdent [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
+newVars s is = deleteAllsBy eqIdent [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
newVar :: [Ident] -> Ident
newVar = head . newVars "q"
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module MicroHs.Exp(
@@ -421,7 +422,7 @@
case ae of
Var i -> [i]
App f a -> freeVars f ++ freeVars a
- Lam i e -> deleteBy eqIdent i (freeVars e)
+ Lam i e -> deleteAllBy eqIdent i (freeVars e)
Lit _ -> []
allVarsExp :: Exp -> [Ident]
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -225,6 +225,8 @@
_ -> error "subst unimplemented"
in sub
+---------------------------------
+
allVarsBind :: EBind -> [Ident]
allVarsBind abind =
case abind of
@@ -284,6 +286,72 @@
SBind p e -> allVarsPat p ++ allVarsExpr e
SThen e -> allVarsExpr e
SLet bs -> concatMap allVarsBind bs
+
+---------------------------------
+
+{- XXX Incomplete +freeVarsBind :: EBind -> [Ident]
+freeVarsBind abind =
+ case abind of
+ BFcn i eqns -> deleteAllBy eqIdent i (concatMap freeVarsEqn eqns)
+ BPat p e -> deleteAllsBy eqIdent (allVarsPat p) (freeVarsExpr e)
+
+freeVarsEqn :: Eqn -> [Ident]
+freeVarsEqn eqn =
+ case eqn of
+ Eqn ps alts -> deleteAllsBy eqIdent (concatMap allVarsPat ps) (freeVarsAlts alts)
+
+freeVarsAlts :: EAlts -> [Ident]
+freeVarsAlts (EAlts alts bs) = concatMap freeVarsAlt alts ++ concatMap freeVarsBind bs
+
+freeVarsAlt :: EAlt -> [Ident]
+freeVarsAlt (ss, e) = concatMap freeVarsStmt ss ++ freeVarsExpr e
+
+freeVarsPat :: EPat -> [Ident]
+freeVarsPat = freeVarsExpr
+
+freeVarsExpr :: Expr -> [Ident]
+freeVarsExpr aexpr =
+ case aexpr of
+ EVar i -> [i]
+ EApp e1 e2 -> freeVarsExpr e1 ++ freeVarsExpr e2
+ EOper e1 ies -> freeVarsExpr e1 ++ concatMap (\ (i,e2) -> i : freeVarsExpr e2) ies
+ ELam ps e -> concatMap freeVarsPat ps ++ freeVarsExpr e
+ ELit _ _ -> []
+ ECase e as -> freeVarsExpr e ++ concatMap freeVarsCaseArm as
+ ELet bs e -> concatMap freeVarsBind bs ++ freeVarsExpr e
+ ETuple es -> concatMap freeVarsExpr es
+ EListish (LList es) -> concatMap freeVarsExpr es
+ EDo mi ss -> maybe [] (:[]) mi ++ concatMap freeVarsStmt ss
+ ESectL e i -> i : freeVarsExpr e
+ ESectR i e -> i : freeVarsExpr e
+ EIf e1 e2 e3 -> freeVarsExpr e1 ++ freeVarsExpr e2 ++ freeVarsExpr e3
+ EListish l -> freeVarsListish l
+ ESign e _ -> freeVarsExpr e
+ EAt i e -> i : freeVarsExpr e
+ EUVar _ -> []
+ ECon c -> [conIdent c]
+
+freeVarsListish :: Listish -> [Ident]
+freeVarsListish (LList es) = concatMap freeVarsExpr es
+freeVarsListish (LCompr e ss) = freeVarsExpr e ++ concatMap freeVarsStmt ss
+freeVarsListish (LFrom e) = freeVarsExpr e
+freeVarsListish (LFromTo e1 e2) = freeVarsExpr e1 ++ freeVarsExpr e2
+freeVarsListish (LFromThen e1 e2) = freeVarsExpr e1 ++ freeVarsExpr e2
+freeVarsListish (LFromThenTo e1 e2 e3) = freeVarsExpr e1 ++ freeVarsExpr e2 ++ freeVarsExpr e3
+
+freeVarsCaseArm :: ECaseArm -> [Ident]
+freeVarsCaseArm (p, alts) = freeVarsPat p ++ freeVarsAlts alts
+
+freeVarsStmt :: EStmt -> [Ident]
+freeVarsStmt astmt =
+ case astmt of
+ SBind p e -> freeVarsPat p ++ freeVarsExpr e
+ SThen e -> freeVarsExpr e
+ SLet bs -> concatMap freeVarsBind bs
+-}
+
+-----------------------------
-- XXX Should use locations in ELit
getSLocExpr :: Expr -> SLoc
--
⑨