From 576e9794839dca76fdcc40ee607a32ac880b2fbb Mon Sep 17 00:00:00 2001
From: Evan Czaplicki <info@elm-lang.org>
Date: Sat, 27 Jul 2013 00:14:38 +0200
Subject: [PATCH] Simplify code to generate record constraints

---
 compiler/SourceSyntax/Type.hs         |  2 +-
 compiler/Type/Constrain/Expression.hs | 37 +++++++++++----------------
 compiler/Type/Type.hs                 |  1 +
 3 files changed, 17 insertions(+), 23 deletions(-)

diff --git a/compiler/SourceSyntax/Type.hs b/compiler/SourceSyntax/Type.hs
index f8e7102..cf04581 100644
--- a/compiler/SourceSyntax/Type.hs
+++ b/compiler/SourceSyntax/Type.hs
@@ -16,7 +16,7 @@ data Type = Lambda Type Type
           | Record [(String,Type)] Type
             deriving (Eq, Show, Data, Typeable)
 
-fieldMap :: [(String,Type)] -> Map.Map String [Type]
+fieldMap :: [(String,a)] -> Map.Map String [a]
 fieldMap fields =
     foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
 
diff --git a/compiler/Type/Constrain/Expression.hs b/compiler/Type/Constrain/Expression.hs
index cb9c55e..cd27cba 100644
--- a/compiler/Type/Constrain/Expression.hs
+++ b/compiler/Type/Constrain/Expression.hs
@@ -108,31 +108,24 @@ constrain env (L _ _ expr) tipe =
 
       Modify e fields ->
           exists $ \t -> do
-              dummyFields <- Map.fromList <$> mapM dummyField fields
-              cOld <- constrain env e (record dummyFields t)
-              (fieldTypes, constraints) <- unzip <$> mapM field fields
-              let cNew = tipe === record (Map.fromList fieldTypes) t
-              return (CAnd (cOld : cNew : constraints))
-          where
-            dummyField (label, _) = do
-                v <- var Flexible -- needs an ex
-                return (label, [VarN v])
+              oldVars <- forM fields $ \_ -> var Flexible
+              let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
+              cOld <- ex oldVars <$> constrain env e (record oldFields t)
 
-            field (label, value) = do
-                v <- var Flexible -- needs an ex
-                c <- ex [v] <$> constrain env value (VarN v)
-                return ((label, [VarN v]), c)
+              newVars <- forM fields $ \_ -> var Flexible
+              let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
+              let cNew = tipe === record newFields t
+
+              cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
+
+              return $ cOld /\ ex newVars (CAnd (cNew : cs))
 
       Record fields ->
-          do (pairs, cs) <- unzip <$> mapM field fields
-             let fieldTypes = Map.fromList (map (second (\t -> [VarN t])) pairs)
-                 recordType = record fieldTypes (TermN EmptyRecord1)
-             return $ ex (map snd pairs) (CAnd (tipe === recordType : cs))
-          where
-            field (name, body) = do
-                v <- var Flexible -- needs an ex
-                c <- constrain env body (VarN v)
-                return ((name, v), c)
+          do vars <- forM fields $ \_ -> var Flexible
+             cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
+             let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
+                 recordType = record fields' (TermN EmptyRecord1)
+             return . ex vars $ CAnd (tipe === recordType : cs)
 
       Markdown _ ->
           return $ tipe === Env.get env Env.types "Element"
diff --git a/compiler/Type/Type.hs b/compiler/Type/Type.hs
index 118fb20..0842421 100644
--- a/compiler/Type/Type.hs
+++ b/compiler/Type/Type.hs
@@ -25,6 +25,7 @@ data TermN a
     | TermN (Term1 (TermN a))
     deriving Show
 
+record :: Map.Map String [TermN a] -> TermN a -> TermN a
 record fs rec = TermN (Record1 fs rec)
 
 type Type = TermN Variable