diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-04-08 16:49:28 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-04-08 16:49:59 +0200 |
commit | a696ca2bbcc2d1c0db8eb1d592a668d443236c9f (patch) | |
tree | b713592d28b53b1b41055e75a930361c06b42fbc /prototypes | |
parent | bf51f0828b390f7ba8703bb7319d7e47bcf27910 (diff) |
add delta functions
Diffstat (limited to 'prototypes')
-rw-r--r-- | prototypes/ShiftReducer.hs | 40 |
1 files changed, 29 insertions, 11 deletions
diff --git a/prototypes/ShiftReducer.hs b/prototypes/ShiftReducer.hs index d9176c6f..b77e0551 100644 --- a/prototypes/ShiftReducer.hs +++ b/prototypes/ShiftReducer.hs | |||
@@ -278,7 +278,7 @@ data Exp e | |||
278 | | ELam (WithLet (Exp e)) -- lambda with used argument | 278 | | ELam (WithLet (Exp e)) -- lambda with used argument |
279 | -- | ELamD (Exp e) -- lambda with unused argument (optimization?) | 279 | -- | ELamD (Exp e) -- lambda with unused argument (optimization?) |
280 | | EApp (Shift (Exp e)) (Shift (Exp e)) -- application | 280 | | EApp (Shift (Exp e)) (Shift (Exp e)) -- application |
281 | | Delta String | 281 | | Delta String [SLExp{-?-}] |
282 | | RHS e -- marks the beginning of right hand side (parts right to the equal sign) in fuction definitions | 282 | | RHS e -- marks the beginning of right hand side (parts right to the equal sign) in fuction definitions |
283 | -- e is either RHSExp or Void; Void means that this constructor cannot be used | 283 | -- e is either RHSExp or Void; Void means that this constructor cannot be used |
284 | deriving (Eq, Show) | 284 | deriving (Eq, Show) |
@@ -320,7 +320,7 @@ instance GetDBUsed RHSExp where | |||
320 | EVar{} -> cons True mempty | 320 | EVar{} -> cons True mempty |
321 | -- ELamD e -> sTail $ getDBUsed e | 321 | -- ELamD e -> sTail $ getDBUsed e |
322 | ELam e -> sTail $ getDBUsed e | 322 | ELam e -> sTail $ getDBUsed e |
323 | Delta{} -> mempty | 323 | Delta _ xs -> mconcat $ getDBUsed <$> xs |
324 | 324 | ||
325 | instance Arbitrary RHSExp where | 325 | instance Arbitrary RHSExp where |
326 | arbitrary = (\(Shift _ (NoLet e)) -> e) . getSimpleExp <$> arbitrary | 326 | arbitrary = (\(Shift _ (NoLet e)) -> e) . getSimpleExp <$> arbitrary |
@@ -515,19 +515,27 @@ pushLet' (Shift u l) = case l of | |||
515 | -} | 515 | -} |
516 | hnf :: SLExp -> SLExp | 516 | hnf :: SLExp -> SLExp |
517 | hnf exp@(Shift u (NoLet e)) = case e of | 517 | hnf exp@(Shift u (NoLet e)) = case e of |
518 | EApp (Shift u' (EApp (Shift _ (Delta "add")) y)) x -> case hnf $ NoLet <$> y of | 518 | EApp f x -> up u $ apl (NoLet <$> f) (NoLet <$> x) |
519 | Int a -> case hnf $ NoLet <$> x of | ||
520 | Int b -> Int $ a + b | ||
521 | a -> error "hnf: TODO1" | ||
522 | EApp f x -> up u $ case hnf (NoLet <$> f) of | ||
523 | Shift u' (NoLet (ELam a)) -> hnf $ let1 0 (NoLet <$> x) $ Shift (Cons (sHead $ getDBUsed a) u') a -- beta reduction | ||
524 | ELam{} -> exp | 519 | ELam{} -> exp |
525 | ELit{} -> exp | 520 | ELit{} -> exp |
521 | Delta "add" [Int i, Int j] -> Int $ j + i | ||
522 | Delta{} -> exp | ||
526 | x -> error $ "hnf: " ++ show x | 523 | x -> error $ "hnf: " ++ show x |
527 | hnf exp@(Shift u (HasLet (Let m e'@(Shift u' e)))) = case NoLet <$> e' of | 524 | hnf exp@(Shift u (HasLet (Let m e'@(Shift u' e)))) = case NoLet <$> e' of |
528 | Var i -> case Map.lookup i m of | 525 | Var i -> case Map.lookup i m of |
529 | Just x -> hnf $ up u $ maybeLet $ mkLet m $ rhs <$> x | 526 | Just x -> hnf $ up u $ maybeLet $ mkLet m $ rhs <$> x |
527 | Shift u' (NoLet (EApp a b)) -> apl (maybeLet $ mkLet m $ up u' a) (maybeLet $ mkLet m $ up u' b) | ||
530 | x -> error $ "hnf2: " ++ show x | 528 | x -> error $ "hnf2: " ++ show x |
529 | |||
530 | apl f x = case hnf f of | ||
531 | Shift u' (NoLet a_) -> case a_ of | ||
532 | ELam a -> hnf $ let1 0 x $ Shift (Cons (sHead $ getDBUsed a) u') a -- beta reduction | ||
533 | Delta s xs | length xs < arity s -> hnf $ Shift u' $ NoLet $ Delta s (hnf x: xs) | ||
534 | x -> error $ "apl: " ++ show x | ||
535 | where | ||
536 | arity "add" = 2 | ||
537 | |||
538 | |||
531 | {- | 539 | {- |
532 | hnf e = case pushLet' e of | 540 | hnf e = case pushLet' e of |
533 | (ExpL (LHS_ "add" [_, _])) -> error "ok" | 541 | (ExpL (LHS_ "add" [_, _])) -> error "ok" |
@@ -553,9 +561,19 @@ idE :: SLExp | |||
553 | idE = lam $ Var 0 | 561 | idE = lam $ Var 0 |
554 | 562 | ||
555 | add :: SLExp | 563 | add :: SLExp |
556 | add = hnf $ f `app` Int 10 `app` Int 20 | 564 | add = NoLet <$> mkShift (Delta "add" []) |
557 | where | 565 | |
558 | f = NoLet <$> mkShift (Delta "add") | 566 | suc :: SLExp |
567 | suc = lam $ add `app` Int 1 `app` Var 0 | ||
568 | |||
569 | -------- | ||
570 | |||
571 | add_test :: SLExp | ||
572 | add_test = hnf $ add `app` Int 10 `app` Int 20 | ||
573 | |||
574 | succ_test :: SLExp | ||
575 | succ_test = hnf $ suc `app` Int 10 | ||
576 | |||
559 | 577 | ||
560 | example1 = hnf $ app idE (Int 10) | 578 | example1 = hnf $ app idE (Int 10) |
561 | {- | 579 | {- |