From 57ac7ed93d048397b36e53d50db6d328e31bd2cc Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Mon, 8 Apr 2019 22:25:40 +0200
Subject: Add auto command

---
 src/Haskell/Rewrite.hs | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

(limited to 'src/Haskell')

diff --git a/src/Haskell/Rewrite.hs b/src/Haskell/Rewrite.hs
index d53eb6f..c33f62e 100644
--- a/src/Haskell/Rewrite.hs
+++ b/src/Haskell/Rewrite.hs
@@ -2,7 +2,9 @@ module Haskell.Rewrite
     (rewrite
     ,betared, etared, casered
     ,etacase, casecase
-    ,normalise) where
+    ,autoSimp
+    ,normalise
+    ,fixpoint) where
 
 import Control.Monad
 import Data.List
@@ -61,6 +63,11 @@ casecase (Case (Case subj arms1) arms2) =
     Case subj [(p, Case e arms2) | (p, e) <- arms1]
 casecase e = recurse id casecase e
 
+autoSimp :: Expr -> Expr
+autoSimp expr =
+    let steps = [betared, casered False, etared, etacase, casecase]
+    in fixpoint (normalise . foldl1 (.) (intersperse normalise steps)) expr
+
 eqPE :: Pat -> Expr -> Bool
 eqPE pat expr = case unify pat expr of
     Nothing -> False
@@ -98,3 +105,9 @@ recurse _  _ (Num k) = Num k
 recurse _  f (Tup es) = Tup (map f es)
 recurse _  f (Lam ns e) = Lam ns (f e)
 recurse fp f (Case e as) = Case (f e) (map (\(p, e') -> (fp p, f e')) as)
+
+fixpoint :: Eq a => (a -> a) -> a -> a
+fixpoint f initVal =
+    let values = iterate f initVal
+        pairs = zip values (tail values)
+    in fst . head $ dropWhile (uncurry (/=)) pairs
-- 
cgit v1.2.3-70-g09d2