aboutsummaryrefslogtreecommitdiff
path: root/src/Haskell
diff options
context:
space:
mode:
authorTom Smeding <tom.smeding@gmail.com>2019-04-08 22:25:40 +0200
committerTom Smeding <tom.smeding@gmail.com>2019-04-08 22:25:40 +0200
commit57ac7ed93d048397b36e53d50db6d328e31bd2cc (patch)
tree9d415443980da7efdda0f23d92c9d06138c1a603 /src/Haskell
parent04cf7ed628e840839e08f0d3c7e624200ded81b3 (diff)
Add auto command
Diffstat (limited to 'src/Haskell')
-rw-r--r--src/Haskell/Rewrite.hs15
1 files changed, 14 insertions, 1 deletions
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