Skip to content

Solve RowToList #2945

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
paf31 merged 1 commit into from
Jul 9, 2017
Merged

Solve RowToList #2945

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
14 changes: 14 additions & 0 deletions src/Language/PureScript/Constants.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
31 changes: 22 additions & 9 deletions src/Language/PureScript/TypeChecker/Entailment.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"

Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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'.
Expand Down