1e6fc9d · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Solving IsSymbol instances (#2429)

* Solve IsSymbol instances * IsSymbol dict with constructor application * IsSymbol solving with Evidence type & comments * Update IsSymbol tests to depend on implicit Data.Symbol import

commit1e6fc9dd68fc199364d4865eed37b7e2fcd6b91f authorLiam Goodacre <goodacre.liam@gmail.com> dateWed 23 Nov 2016, 00:35 (10 years ago) parent79060d4

14 files changed+99−36

compare with golang

unifiedsplit

examples/passing/SolvingIsSymbol.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

7+-- Here we import as alias of reflectSymbol without importing Data.Symbol. However,

8+-- Data.Symbol should be implicitly imported as we have an instance of IsSymbol solved.

9+import SolvingIsSymbol.Lib (literalSymbol, libReflectSymbol)

10+

11+main = do

12+ let lit = libReflectSymbol literalSymbol

13+ when (lit == "literal") (log "Done")

examples/passing/SolvingIsSymbol/Lib.pursnew file+10

@@ -0,0 +1,10 @@

1+module SolvingIsSymbol.Lib where

3+import Data.Symbol

5+literalSymbol :: SProxy "literal"

6+literalSymbol = SProxy

8+libReflectSymbol :: forall s. IsSymbol s => SProxy s -> String

9+libReflectSymbol = reflectSymbol

10+

purescript.cabal+1

@@ -50,6 +50,7 @@ extra-source-files: examples/passing/*.purs

5050 , examples/passing/ResolvableScopeConflict2/*.purs

5151 , examples/passing/ResolvableScopeConflict3/*.purs

5252 , examples/passing/ShadowedModuleName/*.purs

53+ , examples/passing/SolvingIsSymbol/*.purs

5354 , examples/passing/TransitiveImport/*.purs

5455 , examples/passing/TypeOperators/*.purs

5556 , examples/passing/TypeWithoutParens/*.purs

src/Language/PureScript/AST/Declarations.hs+1−1

@@ -607,7 +607,7 @@ data Expr

607607 -- instance type, and the type class dictionaries in scope.

608608 --

609609 | TypeClassDictionary Constraint

610− (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

610+ (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))

611611 [ErrorMessageHint]

612612 -- |

613613 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

src/Language/PureScript/Constants.hs+5

@@ -314,6 +314,11 @@ fromSpine = "fromSpine"

314314toSignature :: String

315315toSignature = "toSignature"

316316

317+-- IsSymbol class

318+

319+pattern IsSymbol :: Qualified (ProperName 'ClassName)

320+pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol")

321+

317322-- Main module

318323

319324main :: String

src/Language/PureScript/CoreFn/Desugar.hs+9−1

@@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals

1313import Language.PureScript.AST.SourcePos

1414import Language.PureScript.AST.Traversals

1515import Language.PureScript.Comments

16+import qualified Language.PureScript.Constants as C

1617import Language.PureScript.CoreFn.Ann

1718import Language.PureScript.CoreFn.Binders

1819import Language.PureScript.CoreFn.Expr

@@ -110,7 +111,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

110111 exprToCoreFn ss com (Just ty) v

111112 exprToCoreFn ss com ty (A.Let ds v) =

112113 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

113− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =

114+ exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) =

115+ exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit)

116+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) =

114117 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

115118 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

116119 in foldl (App (ss, com, Nothing, Nothing)) ctor args

@@ -209,6 +212,11 @@ findQualModules decls =

209212 fqValues :: A.Expr -> [ModuleName]

210213 fqValues (A.Var q) = getQual' q

211214 fqValues (A.Constructor q) = getQual' q

215+ -- IsSymbol instances for literal symbols are automatically solved and the type

216+ -- class dictionaries are built inline instead of having a named instance defined

217+ -- and imported. We therefore need to import the IsSymbol constructor from

218+ -- Data.Symbol if it hasn't already been imported.

219+ fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol

212220 fqValues _ = []

213221

214222 fqBinders :: A.Binder -> [ModuleName]

src/Language/PureScript/Environment.hs+1−1

@@ -29,7 +29,7 @@ data Environment = Environment

2929 -- constructor name, argument types and return type.

3030 , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)

3131 -- ^ Type synonyms currently in scope

32− , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

32+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))

3333 -- ^ Available type class dictionaries

3434 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

3535 -- ^ Type classes

src/Language/PureScript/Externs.hs+1−1

@@ -145,7 +145,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

145145 applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) }

146146 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

147147 where

148− dict :: TypeClassDictionaryInScope

148+ dict :: NamedDict

149149 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs

150150

151151 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a

src/Language/PureScript/TypeChecker.hs+2−2

@@ -134,7 +134,7 @@ addTypeClass moduleName pn args implies dependencies ds =

134134addTypeClassDictionaries

135135 :: (MonadState CheckState m)

136136 => Maybe ModuleName

137− -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

137+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)

138138 -> m ()

139139addTypeClassDictionaries mn entries =

140140 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

@@ -282,7 +282,7 @@ typeCheckAll moduleName _ = traverse go

282282 checkOrphanInstance dictName className tys

283283 _ <- traverseTypeInstanceBody checkInstanceMembers body

284284 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

285− addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict

285+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict

286286 return d

287287 go (PositionedDeclaration pos com d) =

288288 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

src/Language/PureScript/TypeChecker/Entailment.hs+38−21

@@ -19,7 +19,7 @@ import Control.Monad.State

1919import Control.Monad.Supply.Class (MonadSupply(..))

2020import Control.Monad.Writer

2121

22−import Data.Foldable (for_)

22+import Data.Foldable (for_, fold, toList)

2323import Data.Function (on)

2424import Data.List (minimumBy, nub)

2525import Data.Maybe (fromMaybe, maybeToList, mapMaybe)

@@ -37,11 +37,26 @@ import Language.PureScript.TypeClassDictionaries

3737import Language.PureScript.Types

3838import qualified Language.PureScript.Constants as C

3939

40+-- | Describes what sort of dictionary to generate for type class instances

41+data Evidence

42+ = NamedInstance (Qualified Ident)

43+ -- ^ An existing named instance

44+ | IsSymbolInstance String

45+ -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

46+ deriving (Eq)

47+

48+-- | Extract the identifier of a named instance

49+namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident)

50+namedInstanceIdentifier (NamedInstance i) = Just i

51+namedInstanceIdentifier _ = Nothing

52+

53+-- | Description of a type class dictionary with instance evidence

54+type TypeClassDict = TypeClassDictionaryInScope Evidence

55+

4056-- | The 'InstanceContext' tracks those constraints which can be satisfied.

4157type InstanceContext = M.Map (Maybe ModuleName)

4258 (M.Map (Qualified (ProperName 'ClassName))

43− (M.Map (Qualified Ident)

44− TypeClassDictionaryInScope))

59+ (M.Map (Qualified Ident) NamedDict))

4560

4661-- | A type substitution which makes an instance head match a list of types.

4762--

@@ -88,7 +103,7 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d

88103

89104-- | Three options for how we can handle a constraint, depending on the mode we're in.

90105data EntailsResult a

91− = Solved a TypeClassDictionaryInScope

106+ = Solved a TypeClassDict

92107 -- ^ We solved this constraint

93108 | Unsolved Constraint

94109 -- ^ We couldn't solve this constraint right now, it will be generalized

@@ -120,7 +135,8 @@ entails

120135entails SolverOptions{..} constraint context hints =

121136 solve constraint

122137 where

123− forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

138+ forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

139+ forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

124140 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))

125141 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

126142

@@ -130,8 +146,8 @@ entails SolverOptions{..} constraint context hints =

130146 ctorModules (TypeApp ty _) = ctorModules ty

131147 ctorModules _ = Nothing

132148

133− findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

134− findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

149+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]

150+ findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

135151

136152 valUndefined :: Expr

137153 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

@@ -181,7 +197,7 @@ entails SolverOptions{..} constraint context hints =

181197 -- Solve any necessary subgoals

182198 args <- solveSubgoals subst'' (tcdDependencies tcd)

183199 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

184− (mkDictionary (tcdName tcd) args)

200+ (mkDictionary (tcdValue tcd) args)

185201 (tcdPath tcd)

186202 return match

187203 Unsolved unsolved -> do

@@ -213,7 +229,7 @@ entails SolverOptions{..} constraint context hints =

213229 -- fresh type variables. This function extends a substitution with fresh type variables

214230 -- as necessary, based on the types in the instance head.

215231 withFreshTypes

216− :: TypeClassDictionaryInScope

232+ :: TypeClassDict

217233 -> Matching Type

218234 -> m (Matching Type)

219235 withFreshTypes TypeClassDictionaryInScope{..} subst = do

@@ -232,7 +248,7 @@ entails SolverOptions{..} constraint context hints =

232248 t <- freshType

233249 return (s, t)

234250

235− unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

251+ unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a)

236252 unique tyArgs []

237253 | solverDeferErrors = return Deferred

238254 -- We need a special case for nullary type classes, since we want

@@ -242,7 +258,7 @@ entails SolverOptions{..} constraint context hints =

242258 unique _ [(a, dict)] = return $ Solved a dict

243259 unique tyArgs tcds

244260 | pairwiseAny overlapping (map snd tcds) = do

245− tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds)

261+ tell . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd))

246262 return $ uncurry Solved (head tcds)

247263 | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)

248264

@@ -255,12 +271,12 @@ entails SolverOptions{..} constraint context hints =

255271 --

256272 -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have

257273 -- been caught when constructing superclass dictionaries.

258− overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool

274+ overlapping :: TypeClassDict -> TypeClassDict -> Bool

259275 overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False

260276 overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False

261277 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

262278 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

263− overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2

279+ overlapping tcd1 tcd2 = tcdValue tcd1 /= tcdValue tcd2

264280

265281 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

266282 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

@@ -271,10 +287,11 @@ entails SolverOptions{..} constraint context hints =

271287 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

272288

273289 -- Make a dictionary from subgoal dictionaries by applying the correct function

274− mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr

275− mkDictionary fnName Nothing = Var fnName

276− mkDictionary fnName (Just []) = Var fnName

277− mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts

290+ mkDictionary :: Evidence -> Maybe [Expr] -> Expr

291+ mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

292+ mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where

293+ fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))

294+ ]

278295

279296 -- Turn a DictionaryValue into a Expr

280297 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

@@ -286,7 +303,7 @@ entails SolverOptions{..} constraint context hints =

286303-- Check if an instance matches our list of types, allowing for types

287304-- to be solved via functional dependencies. If the types match, we return a

288305-- substitution which makes them match. If not, we return 'Nothing'.

289−matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type])

306+matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Maybe (Matching [Type])

290307matches deps TypeClassDictionaryInScope{..} tys = do

291308 -- First, find those types which match exactly

292309 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

@@ -402,7 +419,7 @@ newDictionaries

402419 => [(Qualified (ProperName 'ClassName), Integer)]

403420 -> Qualified Ident

404421 -> Constraint

405− -> m [TypeClassDictionaryInScope]

422+ -> m [NamedDict]

406423newDictionaries path name (Constraint className instanceTy _) = do

407424 tcs <- gets (typeClasses . checkEnv)

408425 let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

@@ -416,9 +433,9 @@ newDictionaries path name (Constraint className instanceTy _) = do

416433 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

417434 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

418435

419−mkContext :: [TypeClassDictionaryInScope] -> InstanceContext

436+mkContext :: [NamedDict] -> InstanceContext

420437mkContext = foldr combineContexts M.empty . map fromDict where

421− fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d))

438+ fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d))

422439

423440-- | Check all pairs of values in a list match a predicate

424441pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool

src/Language/PureScript/TypeChecker/Monad.hs+4−4

@@ -133,12 +133,12 @@ warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition

133133-- | Temporarily make a collection of type class dictionaries available

134134withTypeClassDictionaries

135135 :: MonadState CheckState m

136− => [TypeClassDictionaryInScope]

136+ => [NamedDict]

137137 -> m a

138138 -> m a

139139withTypeClassDictionaries entries action = do

140140 orig <- get

141− let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

141+ let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdValue entry) entry)) | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } <- entries ]

142142 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

143143 a <- action

144144 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

@@ -147,14 +147,14 @@ withTypeClassDictionaries entries action = do

147147-- | Get the currently available map of type class dictionaries

148148getTypeClassDictionaries

149149 :: (MonadState CheckState m)

150− => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

150+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))

151151getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

152152

153153-- | Lookup type class dictionaries in a module.

154154lookupTypeClassDictionaries

155155 :: (MonadState CheckState m)

156156 => Maybe ModuleName

157− -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

157+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))

158158lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

159159

160160-- | Temporarily bind a collection of names to local variables

src/Language/PureScript/TypeClassDictionaries.hs+9−4

@@ -1,3 +1,5 @@

1+{-# LANGUAGE DeriveFoldable #-}

2+{-# LANGUAGE DeriveTraversable #-}

13module Language.PureScript.TypeClassDictionaries where

35import Prelude.Compat

@@ -8,10 +10,10 @@ import Language.PureScript.Types

810-- |

911-- Data representing a type class dictionary which is in scope

1012--

11−data TypeClassDictionaryInScope

13+data TypeClassDictionaryInScope v

1214 = TypeClassDictionaryInScope {

13− -- | The identifier with which the dictionary can be accessed at runtime

14− tcdName :: Qualified Ident

15+ -- | The value with which the dictionary can be accessed at runtime

16+ tcdValue :: v

1517 -- | How to obtain this instance via superclass relationships

1618 , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

1719 -- | The name of the type class to which this type class instance applies

@@ -21,4 +23,7 @@ data TypeClassDictionaryInScope

2123 -- | Type class dependencies which must be satisfied to construct this dictionary

2224 , tcdDependencies :: Maybe [Constraint]

2325 }

24− deriving (Show)

26+ deriving (Show, Functor, Foldable, Traversable)

27+

28+type NamedDict = TypeClassDictionaryInScope (Qualified Ident)

29+

tests/TestUtils.hs+2

@@ -104,6 +104,7 @@ supportModules =

104104 , "Data.Ring"

105105 , "Data.Semigroup"

106106 , "Data.Semiring"

107+ , "Data.Symbol"

107108 , "Data.Show"

108109 , "Data.Unit"

109110 , "Data.Void"

@@ -112,6 +113,7 @@ supportModules =

112113 , "Prelude"

113114 , "Test.Assert"

114115 , "Test.Main"

116+ , "Unsafe.Coerce"

115117 ]

116118

117119pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json+3−1

@@ -9,6 +9,8 @@

99 "purescript-st": "1.0.0-rc.1",

1010 "purescript-partial": "1.1.2",

1111 "purescript-newtype": "0.1.0",

12− "purescript-generics-rep": "2.0.0"

12+ "purescript-generics-rep": "2.0.0",

13+ "purescript-symbols": "^1.0.1",

14+ "purescript-unsafe-coerce": "^1.0.0"

1315 }

1416}