1e6fc9d · rowtype-yoga/purescript-native

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

on golang help sign in

Solving IsSymbol instances (#2429)

1e6fc9dLiam Goodacre10 years ago

examples/passing/SolvingIsSymbol.pursnew file+13

compare with golang

unifiedsplit

@@ -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

50 , examples/passing/ResolvableScopeConflict2/*.purs

51 , examples/passing/ResolvableScopeConflict3/*.purs

52 , examples/passing/ShadowedModuleName/*.purs

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

53 , examples/passing/TransitiveImport/*.purs

54 , examples/passing/TransitiveImport/*.purs

54 , examples/passing/TypeOperators/*.purs

55 , examples/passing/TypeOperators/*.purs

55 , examples/passing/TypeWithoutParens/*.purs

56 , examples/passing/TypeWithoutParens/*.purs

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

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

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

608 --

609 | 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)))

611 [ErrorMessageHint]

612 -- |

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

src/Language/PureScript/Constants.hs+5

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

314toSignature :: String

315toSignature = "toSignature"

316

317+-- IsSymbol class

318+

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

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

321+

317-- Main module

322-- Main module

318

323

319main :: String

324main :: String

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

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

13import Language.PureScript.AST.SourcePos

14import Language.PureScript.AST.Traversals

15import Language.PureScript.Comments

16+import qualified Language.PureScript.Constants as C

16import Language.PureScript.CoreFn.Ann

17import Language.PureScript.CoreFn.Ann

17import Language.PureScript.CoreFn.Binders

18import Language.PureScript.CoreFn.Binders

18import Language.PureScript.CoreFn.Expr

19import Language.PureScript.CoreFn.Expr

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

110 exprToCoreFn ss com (Just ty) v

111 exprToCoreFn ss com (Just ty) v

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

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

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

113 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))) =

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

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

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

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

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

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

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

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

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

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

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

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

214 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

212 fqValues _ = []

220 fqValues _ = []

213

221

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

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

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

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

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

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

31 -- ^ 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))

33 -- ^ Available type class dictionaries

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

35 -- ^ Type classes

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

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

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

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

147 where

148− dict :: TypeClassDictionaryInScope

148+ dict :: NamedDict

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

150

151 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 =

134addTypeClassDictionaries

135 :: (MonadState CheckState m)

136 => Maybe ModuleName

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

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

138 -> m ()

139addTypeClassDictionaries mn entries =

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

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

282 checkOrphanInstance dictName className tys

283 _ <- traverseTypeInstanceBody checkInstanceMembers body

284 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

286 return d

287 go (PositionedDeclaration pos com d) =

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

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

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

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

20import Control.Monad.Writer

22−import Data.Foldable (for_)

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

23import Data.Function (on)

24import Data.List (minimumBy, nub)

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

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

37import Language.PureScript.Types

38import qualified Language.PureScript.Constants as C

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+

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

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

41type InstanceContext = M.Map (Maybe ModuleName)

57type InstanceContext = M.Map (Maybe ModuleName)

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

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

43− (M.Map (Qualified Ident)

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

44− TypeClassDictionaryInScope))

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

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

47--

62--

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

103

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

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

90data EntailsResult a

105data EntailsResult a

91− = Solved a TypeClassDictionaryInScope

106+ = Solved a TypeClassDict

92 -- ^ We solved this constraint

107 -- ^ We solved this constraint

93 | Unsolved Constraint

108 | Unsolved Constraint

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

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

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

120entails SolverOptions{..} constraint context hints =

135entails SolverOptions{..} constraint context hints =

121 solve constraint

136 solve constraint

122 where

137 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]

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

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

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

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

126

142

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

130 ctorModules (TypeApp ty _) = ctorModules ty

146 ctorModules (TypeApp ty _) = ctorModules ty

131 ctorModules _ = Nothing

147 ctorModules _ = Nothing

132

148

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

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

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

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

135

151

136 valUndefined :: Expr

152 valUndefined :: Expr

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

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

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

181 -- Solve any necessary subgoals

197 -- Solve any necessary subgoals

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

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

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

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

184− (mkDictionary (tcdName tcd) args)

200+ (mkDictionary (tcdValue tcd) args)

185 (tcdPath tcd)

201 (tcdPath tcd)

186 return match

202 return match

187 Unsolved unsolved -> do

203 Unsolved unsolved -> do

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

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

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

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

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

215 withFreshTypes

231 withFreshTypes

216− :: TypeClassDictionaryInScope

232+ :: TypeClassDict

217 -> Matching Type

233 -> Matching Type

218 -> m (Matching Type)

234 -> m (Matching Type)

219 withFreshTypes TypeClassDictionaryInScope{..} subst = do

235 withFreshTypes TypeClassDictionaryInScope{..} subst = do

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

232 t <- freshType

248 t <- freshType

233 return (s, t)

249 return (s, t)

234

250

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

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

236 unique tyArgs []

252 unique tyArgs []

237 | solverDeferErrors = return Deferred

253 | solverDeferErrors = return Deferred

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

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

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

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

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

243 unique tyArgs tcds

259 unique tyArgs tcds

244 | pairwiseAny overlapping (map snd tcds) = do

260 | 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))

246 return $ uncurry Solved (head tcds)

262 return $ uncurry Solved (head tcds)

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

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

248

264

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

255 --

271 --

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

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

257 -- been caught when constructing superclass dictionaries.

273 -- been caught when constructing superclass dictionaries.

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

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

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

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

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

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

261 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

277 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

262 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

278 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

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

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

264

280

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

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

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

282 -- 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 =

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

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

272

288

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

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

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

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

275− mkDictionary fnName Nothing = Var fnName

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

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

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

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

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

294+ ]

278

295

279 -- Turn a DictionaryValue into a Expr

296 -- Turn a DictionaryValue into a Expr

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

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

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

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

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

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

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

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

305-- 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])

290matches deps TypeClassDictionaryInScope{..} tys = do

307matches deps TypeClassDictionaryInScope{..} tys = do

291 -- First, find those types which match exactly

308 -- First, find those types which match exactly

292 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

309 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

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

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

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

403 -> Qualified Ident

420 -> Qualified Ident

404 -> Constraint

421 -> Constraint

405− -> m [TypeClassDictionaryInScope]

422+ -> m [NamedDict]

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

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

407 tcs <- gets (typeClasses . checkEnv)

424 tcs <- gets (typeClasses . checkEnv)

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

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

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

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

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

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

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

418

435

419−mkContext :: [TypeClassDictionaryInScope] -> InstanceContext

436+mkContext :: [NamedDict] -> InstanceContext

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

437mkContext = 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))

422

439

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

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

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

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

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

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

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

134withTypeClassDictionaries

135 :: MonadState CheckState m

136− => [TypeClassDictionaryInScope]

136+ => [NamedDict]

137 -> m a

138 -> m a

139withTypeClassDictionaries entries action = do

140 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 ]

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

143 a <- action

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

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

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

148getTypeClassDictionaries

149 :: (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)))

151getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

152

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

154lookupTypeClassDictionaries

155 :: (MonadState CheckState m)

156 => 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))

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

159

160-- | 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 #-}

1module Language.PureScript.TypeClassDictionaries where

3module Language.PureScript.TypeClassDictionaries where

3import Prelude.Compat

5import Prelude.Compat

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

8-- |

10-- |

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

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

10--

12--

11−data TypeClassDictionaryInScope

13+data TypeClassDictionaryInScope v

12 = TypeClassDictionaryInScope {

14 = TypeClassDictionaryInScope {

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

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

14− tcdName :: Qualified Ident

16+ tcdValue :: v

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

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

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

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

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

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

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

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

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

22 , tcdDependencies :: Maybe [Constraint]

24 , tcdDependencies :: Maybe [Constraint]

23 }

25 }

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 =

104 , "Data.Ring"

105 , "Data.Semigroup"

106 , "Data.Semiring"

107+ , "Data.Symbol"

107 , "Data.Show"

108 , "Data.Show"

108 , "Data.Unit"

109 , "Data.Unit"

109 , "Data.Void"

110 , "Data.Void"

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

112 , "Prelude"

113 , "Prelude"

113 , "Test.Assert"

114 , "Test.Assert"

114 , "Test.Main"

115 , "Test.Main"

116+ , "Unsafe.Coerce"

115 ]

117 ]

116

118

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

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

tests/support/bower.json+3−1

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

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

10 "purescript-partial": "1.1.2",

11 "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"

13 }

15 }

14}

16}