easier code with auto

AvlTree.hs

@@ -1,6 +1,12 @@
 {-# OPTIONS -Wall #-}
 {-# LANGUAGE EmptyDataDecls, FlexibleInstances, GADTs #-}
 
+module AvlTree
+    ( Tree
+    , empty, insert
+    , fromList, toList
+    ) where
+
 import Data.List (foldl')
 
 data Zero
@@ -57,59 +63,72 @@ data InsertResultRule new old where
     InsertHigher :: InsertResultRule (Succ n) n
 
 nodeInsert :: Ord a => a -> Node n a -> InsertResult n a
-nodeInsert x Nil = InsertResult InsertHigher (Node SameHeight Nil x Nil)
+nodeInsert x Nil = InsertResult auto (Node SameHeight Nil x Nil)
 nodeInsert x node@(Node _ _ mid _) = nodeInsertH (x >= mid) x node
 
+class Auto a where
+    auto :: a
+instance Auto (InsertResultRule n n) where
+    auto = InsertSame
+instance Auto (InsertResultRule (Succ n) n) where
+    auto = InsertHigher
+instance Auto (HeightRule (Succ n) (Succ n) n) where
+    auto = LeftHigher
+instance Auto (HeightRule n n n) where
+    auto = SameHeight
+instance Auto (HeightRule (Succ n) n (Succ n)) where
+    auto = RightHigher
+
 nodeInsertH :: Ord a => Bool -> a -> Node (Succ n) a -> InsertResult (Succ n) a
 nodeInsertH isRev x node =
     case revNode isRev node of
     Node rule left mid right ->
         case nodeInsert x left of
-        InsertResult InsertSame newLeft -> InsertResult InsertSame . revNode isRev $ Node rule newLeft mid right
+        InsertResult InsertSame newLeft -> InsertResult auto . revNode isRev $ Node rule newLeft mid right
         InsertResult InsertHigher newLeft -> nodeBalanceH isRev rule newLeft mid right
 
 revNode :: Bool -> Node n a -> Node n a
 revNode False x = x
 revNode _ Nil = Nil
 revNode True (Node rule left mid right) =
     case rule of
-    LeftHigher -> go RightHigher
-    SameHeight -> go SameHeight
-    RightHigher -> go LeftHigher
+    LeftHigher -> go auto
+    SameHeight -> go auto
+    RightHigher -> go auto
     where
         go newRule = Node newRule right mid left
 
 nodeBalanceH :: Bool -> HeightRule n l r -> Node (Succ l) a -> a -> Node r a -> InsertResult (Succ n) a
 nodeBalanceH isRev rule left mid right =
     case rule of
-    RightHigher -> go InsertSame SameHeight
-    SameHeight -> go InsertHigher LeftHigher
+    RightHigher -> go SameHeight
+    SameHeight -> go LeftHigher
     LeftHigher -> rotate isRev left mid right
     where
-        go insRule newRule = InsertResult insRule . revNode isRev $ Node newRule left mid right
+        go newRule = InsertResult auto . revNode isRev $ Node newRule left mid right
 
 rotate :: Bool -> Node (Succ (Succ n)) a -> a -> Node n a -> InsertResult (Succ (Succ n)) a
 rotate isRev l m r =
     case revNode isRev l of
     Node lRule ll lm lr ->
         let
-            go0 r0 r1 r2 = InsertResult r0 . revNode isRev . Node r1 ll lm . revNode isRev $ Node r2 lr m r
+            go0 r1 = InsertResult auto . revNode isRev . Node r1 ll lm . revNode isRev $ Node auto lr m r
         in
         case lRule of
-        LeftHigher -> go0 InsertSame SameHeight SameHeight
-        SameHeight -> go0 InsertHigher RightHigher LeftHigher
+        LeftHigher -> go0 SameHeight
+        SameHeight -> go0 RightHigher
         RightHigher ->
             case revNode isRev lr of
             Nil -> undefined -- should never happen
             Node lrRule lrl lrm lrr ->
                 let
-                    go1 leftRule rightRule =
-                        InsertResult InsertSame . revNode isRev $ Node SameHeight
+                    go1 leftRule =
+                        InsertResult auto . revNode isRev $ Node SameHeight
                             (revNode isRev $ Node leftRule ll lm lrl)
                             lrm
-                            (revNode isRev $ Node rightRule lrr m r)
+                            (revNode isRev $ Node auto lrr m r)
                 in
                 case lrRule of
-                LeftHigher -> go1 SameHeight RightHigher
-                SameHeight -> go1 SameHeight SameHeight
-                RightHigher -> go1 LeftHigher SameHeight
+                LeftHigher -> go1 SameHeight
+                SameHeight -> go1 SameHeight
+                RightHigher -> go1 LeftHigher