From 82ca695dcab510376d2a58c1842a6c157071fdd9 Mon Sep 17 00:00:00 2001
From: Evan Czaplicki <info@elm-lang.org>
Date: Thu, 25 Jul 2013 01:24:16 +0200
Subject: [PATCH] Add support for "number" type which can be either an Int or
 Float

---
 compiler/Type/Environment.hs | 21 ++++++++++++++++++---
 compiler/Type/State.hs       |  4 +++-
 compiler/Type/Type.hs        |  6 +++++-
 compiler/Type/Unify.hs       | 31 ++++++++++++++++++++++++++++---
 4 files changed, 54 insertions(+), 8 deletions(-)

diff --git a/compiler/Type/Environment.hs b/compiler/Type/Environment.hs
index ba2a7b5..58d461c 100644
--- a/compiler/Type/Environment.hs
+++ b/compiler/Type/Environment.hs
@@ -53,12 +53,21 @@ makeConstructors types = Map.fromList builtins
   where
     list  t = (types ! "_List") <| t
     maybe t = (types ! "Maybe") <| t
+    bool = types ! "Bool"
+    int = types ! "Int"
+    float = types ! "Float"
 
     inst :: Int -> Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
     inst kind numTVars tipe = do
-       vars <- forM [1..numTVars] $ \_ -> flexibleVar
-       let (args, result) = tipe (map VarN vars)
-       return (kind, vars, args, result)
+      vars <- forM [1..numTVars] $ \_ -> flexibleVar
+      let (args, result) = tipe (map VarN vars)
+      return (kind, vars, args, result)
+
+    nmbr :: Int -> (Type -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
+    nmbr kind tipe = do
+      var <- number
+      let (args, result) = tipe (VarN var)
+      return (kind, [var], args, result)
 
     tupleCtor n =
         let name = "_Tuple" ++ show n
@@ -69,6 +78,12 @@ makeConstructors types = Map.fromList builtins
                , ("Just"   , inst 1 1 $ \ [t] -> ([t], maybe t))
                , ("[]"     , inst 0 1 $ \ [t] -> ([], list t))
                , ("::"     , inst 2 1 $ \ [t] -> ([t, list t], list t))
+               , ("div"    , inst 2 0 $ \ [] -> ([int, int], int))
+               , ("/"      , inst 2 0 $ \ [] -> ([float, float], float))
+               , ("+"      , nmbr 2 $ \t -> ([t, t], t))
+               , ("-"      , nmbr 2 $ \t -> ([t, t], t))
+               , ("*"      , nmbr 2 $ \t -> ([t, t], t))
+               , ("otherwise", inst 0 0 $ \ [] -> ([], bool))
                ] ++ map tupleCtor [0..9]
 
 
diff --git a/compiler/Type/State.hs b/compiler/Type/State.hs
index 83ee1b5..0c90620 100644
--- a/compiler/Type/State.hs
+++ b/compiler/Type/State.hs
@@ -138,7 +138,9 @@ makeCopy alreadyCopied variable = do
                      structure = Nothing,
                      rank = maxRank pool,
                      mark = noMark,
-                     flex = Flexible,
+                     flex = case flex desc of
+                              IsIn s -> IsIn s
+                              _ -> Flexible,
                      copy = Nothing,
                      name = case flex desc of
                               Rigid -> Nothing
diff --git a/compiler/Type/Type.hs b/compiler/Type/Type.hs
index 637ad44..54d224b 100644
--- a/compiler/Type/Type.hs
+++ b/compiler/Type/Type.hs
@@ -69,7 +69,10 @@ outermostRank = 0 :: Int
 noMark = 0
 initialMark = 1
 
-data Flex = Rigid | Flexible | Constant
+data Flex = Rigid | Flexible | Constant | IsIn SuperType
+     deriving (Show, Eq)
+
+data SuperType = Number | Comparable | Appendable
      deriving (Show, Eq)
 
 infixl 8 /\
@@ -91,6 +94,7 @@ a ==> b = TermN (Fun1 a b)
 
 f <| a = TermN (App1 f a)
 
+number = namedVar (IsIn Number) "number"
 
 namedVar flex name = UF.fresh $ Descriptor {
     structure = Nothing,
diff --git a/compiler/Type/Unify.hs b/compiler/Type/Unify.hs
index 0274d73..0d5a78d 100644
--- a/compiler/Type/Unify.hs
+++ b/compiler/Type/Unify.hs
@@ -70,6 +70,30 @@ actuallyUnify variable1 variable2 = do
                }
         TS.register var
 
+      flexAndUnify var = do
+        liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
+        unify variable1 variable2
+
+      superUnify =
+          case (flex desc1, flex desc2, name desc1, name desc2) of
+            (IsIn Number, IsIn Number, _, _) -> merge
+            (IsIn Number, IsIn Comparable, _, _) -> merge1
+            (IsIn Comparable, IsIn Number, _, _) -> merge2
+
+            (IsIn Number, _, _, Just name)
+                | name == "Int" || name == "Float" -> flexAndUnify variable1
+
+            (_, IsIn Number, Just name, _)
+                | name == "Int" || name == "Float" -> flexAndUnify variable2
+
+            (IsIn Comparable, _, _, Just name)
+                | name == "Int" || name == "Float" -> flexAndUnify variable1
+
+            (_, IsIn Comparable, Just name, _)
+                | name == "Int" || name == "Float" -> flexAndUnify variable2
+
+            _ -> TS.addError "The following types are not equal" variable1 variable2
+
   case (structure desc1, structure desc2) of
     (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
     (Nothing, _) | flex desc1 == Flexible -> merge2
@@ -78,8 +102,8 @@ actuallyUnify variable1 variable2 = do
     (Just (Var1 v), _) -> unify v variable2
     (_, Just (Var1 v)) -> unify v variable1
 
-    (Nothing, _) -> TS.addError "The following types are not equal" variable1 variable2
-    (_, Nothing) -> TS.addError "The following types are not equal" variable1 variable2
+    (Nothing, _) -> superUnify
+    (_, Nothing) -> superUnify
 
     (Just type1, Just type2) ->
         case (type1,type2) of
@@ -98,4 +122,5 @@ actuallyUnify variable1 variable2 = do
           (Record1 fields1 ext1, Record1 fields2 ext2) ->
               TS.addError "did not write record unification yet" variable1 variable2
 
-          _ -> TS.addError "could not unify types" variable1 variable2
\ No newline at end of file
+          _ -> TS.addError "could not unify types" variable1 variable2
+