From ac9835a7a0714616a01093da7eb8fa56accabda0 Mon Sep 17 00:00:00 2001
From: Liam Goodacre <goodacre.liam@gmail.com>
Date: Sat, 17 Jun 2017 00:26:32 +0100
Subject: [PATCH] Solve RowToList

---
 src/Language/PureScript/Constants.hs          | 14 +++++++++
 .../PureScript/TypeChecker/Entailment.hs      | 31 +++++++++++++------
 2 files changed, 36 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 0f2fd0050e..73341f80c4 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -359,6 +359,20 @@ orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ")
 orderingGT :: Qualified (ProperName 'TypeName)
 orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT")
 
+-- Type.Row
+
+pattern TypeRow :: ModuleName
+pattern TypeRow = ModuleName [ProperName "Type", ProperName "Row"]
+
+pattern RowToList :: Qualified (ProperName 'ClassName)
+pattern RowToList = Qualified (Just TypeRow) (ProperName "RowToList")
+
+pattern RowListNil :: Qualified (ProperName 'TypeName)
+pattern RowListNil = Qualified (Just TypeRow) (ProperName "Nil")
+
+pattern RowListCons :: Qualified (ProperName 'TypeName)
+pattern RowListCons = Qualified (Just TypeRow) (ProperName "Cons")
+
 -- Main module
 
 main :: forall a. (IsString a) => a
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index e9f3d84ebd..2ab173496f 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -44,20 +44,17 @@ import qualified Language.PureScript.Constants as C
 
 -- | Describes what sort of dictionary to generate for type class instances
 data Evidence
+  -- | An existing named instance
   = NamedInstance (Qualified Ident)
-  -- ^ An existing named instance
-  | WarnInstance Type
-  -- ^ Computed instance of the Warn type class with a user-defined warning message
-  | IsSymbolInstance PSString
-  -- ^ Computed instance of the IsSymbol type class for a given Symbol literal
+
+  -- | Computed instances
+  | WarnInstance Type         -- ^ Warn type class with a user-defined warning message
+  | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal
   | CompareSymbolInstance
-  -- ^ Computed instance of CompareSymbol
   | AppendSymbolInstance
-  -- ^ Computed instance of AppendSymbol
   | UnionInstance
-  -- ^ Computed instance of Union
   | ConsInstance
-  -- ^ Computed instance of RowCons
+  | RowToListInstance
   deriving (Show, Eq)
 
 -- | Extract the identifier of a named instance
@@ -173,6 +170,9 @@ entails SolverOptions{..} constraint context hints =
       = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ]
     forClassName _ C.RowCons [TypeLevelString sym, ty, r, _]
       = [ TypeClassDictionaryInScope ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ]
+    forClassName _ C.RowToList [r, _]
+      | Just entries <- solveRowToList r
+      = [ TypeClassDictionaryInScope RowToListInstance [] C.RowToList [r, entries] Nothing ]
     forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))
     forClassName _ _ _ = internalError "forClassName: expected qualified class name"
 
@@ -333,6 +333,7 @@ entails SolverOptions{..} constraint context hints =
               return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e
             mkDictionary UnionInstance _ = return valUndefined
             mkDictionary ConsInstance _ = return valUndefined
+            mkDictionary RowToListInstance _ = return valUndefined
             mkDictionary (WarnInstance msg) _ = do
               tell . errorMessage $ UserDefinedWarning msg
               -- We cannot call the type class constructor here because Warn is declared in Prim.
@@ -374,6 +375,18 @@ entails SolverOptions{..} constraint context hints =
             -- types for such labels.
             _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ])
 
+    -- | Convert a closed row to a sorted list of entries
+    solveRowToList :: Type -> Maybe Type
+    solveRowToList r =
+        guard (REmpty == rest) $>
+        foldr rowListCons (TypeConstructor C.RowListNil) fixed
+      where
+        (fixed, rest) = rowToSortedList r
+        rowListCons (lbl, ty) tl = foldl TypeApp (TypeConstructor C.RowListCons)
+                                     [ TypeLevelString (runLabel lbl)
+                                     , ty
+                                     , tl ]
+
 -- Check if an instance matches our list of types, allowing for types
 -- to be solved via functional dependencies. If the types match, we return a
 -- substitution which makes them match. If not, we return 'Nothing'.