diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-05-21 08:53:58 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-05-21 08:53:58 +0200 |
commit | 45981b9a6233df6f53680f6011159ce2631e93da (patch) | |
tree | 4825594bf2f512908db2073d0774e287c3e714ff | |
parent | 69006a4c5ea96c9466fe2ec0edbd95537c5a2e72 (diff) |
refactoring
-rw-r--r-- | prototypes/LamMachine.hs | 13 |
1 files changed, 7 insertions, 6 deletions
diff --git a/prototypes/LamMachine.hs b/prototypes/LamMachine.hs index 23416fea..f88062b0 100644 --- a/prototypes/LamMachine.hs +++ b/prototypes/LamMachine.hs | |||
@@ -54,11 +54,11 @@ instance PShow Exp where | |||
54 | Lam e -> shLam $ pShow e | 54 | Lam e -> shLam $ pShow e |
55 | Con s i xs -> foldl DApp (text s) $ pShow <$> xs | 55 | Con s i xs -> foldl DApp (text s) $ pShow <$> xs |
56 | Int i -> pShow i | 56 | Int i -> pShow i |
57 | Y e -> "Y" `DApp` pShow e | ||
57 | Op1 o x -> text (show o) `DApp` pShow x | 58 | Op1 o x -> text (show o) `DApp` pShow x |
58 | Op2 EqInt x y -> DOp "==" (Infix 4) (pShow x) (pShow y) | 59 | Op2 EqInt x y -> DOp "==" (Infix 4) (pShow x) (pShow y) |
59 | Op2 Add x y -> DOp "+" (InfixL 6) (pShow x) (pShow y) | 60 | Op2 Add x y -> DOp "+" (InfixL 6) (pShow x) (pShow y) |
60 | Op2 o x y -> text (show o) `DApp` pShow x `DApp` pShow y | 61 | Op2 o x y -> text (show o) `DApp` pShow x `DApp` pShow y |
61 | Y e -> "Y" `DApp` pShow e | ||
62 | Case cn e xs -> DPreOp (-20) (ComplexAtom "case" (-10) (pShow e) (SimpleAtom "of")) | 62 | Case cn e xs -> DPreOp (-20) (ComplexAtom "case" (-10) (pShow e) (SimpleAtom "of")) |
63 | $ foldr1 DSemi [DArr_ "->" (text a) (pShow b) | (a, b) <- zip cn xs] | 63 | $ foldr1 DSemi [DArr_ "->" (text a) (pShow b) | (a, b) <- zip cn xs] |
64 | 64 | ||
@@ -276,6 +276,7 @@ steps nostep {-ready-} bind cont dt@(MSt t e vs) = case e of | |||
276 | Lam x -> step "appdel" $ tryRemoves (fvs b) $ MSt t x vs | 276 | Lam x -> step "appdel" $ tryRemoves (fvs b) $ MSt t x vs |
277 | Var i -> lookupHNF' "appvar" (\e (App _ y) -> App e y) i dt | 277 | Var i -> lookupHNF' "appvar" (\e (App _ y) -> App e y) i dt |
278 | _ -> step "appexp" $ MSt (up 1 1 t) (App (Var 0) $ up 0 1 b) $ a: vs | 278 | _ -> step "appexp" $ MSt (up 1 1 t) (App (Var 0) $ up 0 1 b) $ a: vs |
279 | -- _ -> bind "appexp" (lookupHNF' "app1var" (\e (App _ y) -> App e y) 0) $ MSt (up 1 1 t) (App (Var 0) $ up 0 1 b) $ a: vs | ||
279 | 280 | ||
280 | Case cn a cs -> case a of | 281 | Case cn a cs -> case a of |
281 | Con cn i es -> step "case" $ tryRemoves (nub $ foldMap fvs $ delElem i cs) $ (MSt t (foldl App (cs !! i) es) vs) | 282 | Con cn i es -> step "case" $ tryRemoves (nub $ foldMap fvs $ delElem i cs) $ (MSt t (foldl App (cs !! i) es) vs) |
@@ -306,22 +307,22 @@ steps nostep {-ready-} bind cont dt@(MSt t e vs) = case e of | |||
306 | 307 | ||
307 | -- lookup var in head normal form | 308 | -- lookup var in head normal form |
308 | lookupHNF_ :: (MSt -> e) -> StepTag -> (Exp -> Exp -> Exp) -> Int -> MSt -> e | 309 | lookupHNF_ :: (MSt -> e) -> StepTag -> (Exp -> Exp -> Exp) -> Int -> MSt -> e |
309 | lookupHNF_ end msg f i dt = bind "shiftL" (hnf shiftLookup) $ iterate shiftL dt !! (i+1) | 310 | lookupHNF_ end msg f i dt = bind msg (hnf shiftLookup) $ iterate shiftL dt !! (i+1) |
310 | where | 311 | where |
311 | shiftLookup dt@(MSt _ e _) | 312 | shiftLookup dt@(MSt _ e _) |
312 | = case iterate shiftR dt !! (i+1) of | 313 | = case iterate shiftR dt !! (i+1) of |
313 | MSt xs z es -> bind "shiftR" (tryRemove i) $ MSt xs (f (up 0 (i+1) e) z) es | 314 | MSt xs z es -> bind "shiftR" (tryRemove i) $ MSt xs (f (up 0 (i+1) e) z) es |
314 | 315 | ||
315 | shiftL (MSt xs x (e: es)) = MSt (Let x xs) e es | ||
316 | |||
317 | shiftR (MSt (Let x xs) e es) = MSt xs x $ e: es | ||
318 | |||
319 | tryRemove i st = {-maybe (end st)-} (bind "remove" end) $ tryRemoves [i] st | 316 | tryRemove i st = {-maybe (end st)-} (bind "remove" end) $ tryRemoves [i] st |
320 | 317 | ||
321 | -- lookup & step | 318 | -- lookup & step |
322 | lookupHNF' :: StepTag -> (Exp -> Exp -> Exp) -> Int -> MSt -> e | 319 | lookupHNF' :: StepTag -> (Exp -> Exp -> Exp) -> Int -> MSt -> e |
323 | lookupHNF' msg f i dt = lookupHNF_ rec msg f i dt | 320 | lookupHNF' msg f i dt = lookupHNF_ rec msg f i dt |
324 | 321 | ||
322 | shiftL (MSt xs x (e: es)) = MSt (Let x xs) e es | ||
323 | |||
324 | shiftR (MSt (Let x xs) e es) = MSt xs x $ e: es | ||
325 | |||
325 | simple = \case | 326 | simple = \case |
326 | Var{} -> True | 327 | Var{} -> True |
327 | Int{} -> True | 328 | Int{} -> True |