8ca3d1e · rowtype-yoga/purescript-native

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

Distinguish between the different ProperNames

commit8ca3d1e68bb49ca979a8272f3913cdcefc115cd9 authorGary Burgess <gary.burgess@gmail.com> dateWed 30 Dec 2015, 01:44 (11 years ago) parent3bec40c

39 files changed+805−673

compare with golang

unifiedsplit

hierarchy/Main.hs+2−1

@@ -14,6 +14,7 @@

1414-----------------------------------------------------------------------------

1515

1616{-# LANGUAGE TupleSections #-}

17+{-# LANGUAGE DataKinds #-}

1718

1819module Main where

1920

@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions

3839 , hierarchyOutput :: Maybe FilePath

3940 }

4041

41−newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }

42+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }

4243 deriving Eq

4344

4445instance Show SuperMap where

psci/Completion.hs+6−4

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

1+{-# LANGUAGE DataKinds #-}

13module Completion where

35import Prelude ()

@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf

184186nubOnFst :: Eq a => [(a, b)] -> [(a, b)]

185187nubOnFst = nubBy ((==) `on` fst)

186188

187−typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]

189+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]

188190typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations

189191 where

190− getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)

192+ getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)

191193 getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)

192194 getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)

193195 getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d

@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations

204206 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d

205207 getDeclNames _ = []

206208

207−dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]

209+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

208210dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

209211 where

210− go :: P.Declaration -> [(N.ProperName, P.Declaration)]

212+ go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

211213 go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)

212214 go (P.PositionedDeclaration _ _ d) = go d

213215 go _ = []

psci/PSCi.hs+20−10

@@ -2,6 +2,7 @@

22{-# LANGUAGE GeneralizedNewtypeDeriving #-}

33{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TupleSections #-}

5+{-# LANGUAGE DataKinds #-}

67-- |

78-- PureScript Compiler Interactive.

@@ -326,7 +327,7 @@ handleShowImportedModules = do

326327 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

327328 showRef (P.ValueRef ident) = N.runIdent ident

328329 showRef (P.TypeClassRef pn) = N.runProperName pn

329− showRef (P.ProperRef pn) = N.runProperName pn

330+ showRef (P.ProperRef pn) = pn

330331 showRef (P.TypeInstanceRef ident) = N.runIdent ident

331332 showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

332333 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

@@ -391,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) =

391392 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

392393 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

393394

394− findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

395+ findTypeClass

396+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

397+ -> P.Qualified (P.ProperName 'P.ClassName)

398+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

395399 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

396400

397− showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box

401+ showTypeClass

402+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

403+ -> Maybe Box.Box

398404 showTypeClass (_, Nothing) = Nothing

399405 showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

400406 let constraints =

@@ -418,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) =

418424 Box.// Box.moveRight 2 classBody

419425

420426

421− findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

427+ findType

428+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

429+ -> P.Qualified (P.ProperName 'P.TypeName)

430+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

422431 findType envTypes name = (name, M.lookup name envTypes)

423432

424− showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

425− -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])

426− -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)

427− -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

428− -> Maybe Box.Box

433+ showType

434+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

435+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

436+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

437+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

438+ -> Maybe Box.Box

429439 showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

430440 case (typ, M.lookup n typeSynonymsEnv) of

431441 (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

432− if M.member n typeClassesEnv

442+ if M.member (fmap P.coerceProperName n) typeClassesEnv

433443 then

434444 Nothing

435445 else

purescript.cabal+2

@@ -178,6 +178,8 @@ library

178178 Control.Monad.Supply.Class

179179

180180 System.IO.UTF8

181+

182+ extensions: DataKinds

181183 exposed: True

182184 buildable: True

183185 hs-source-dirs: src

src/Language/PureScript.hs−1

@@ -13,7 +13,6 @@

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE DataKinds #-}

1716{-# LANGUAGE FlexibleContexts #-}

1817{-# LANGUAGE ScopedTypeVariables #-}

1918

src/Language/PureScript/AST/Binders.hs+4−15

@@ -1,19 +1,8 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.AST.Binders

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Case binders

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162

3+-- |

4+-- Case binders

5+--

176module Language.PureScript.AST.Binders where

187

198import qualified Data.Data as D

@@ -54,7 +43,7 @@ data Binder

5443 -- |

5544 -- A binder which matches a data constructor

5645 --

57− | ConstructorBinder (Qualified ProperName) [Binder]

46+ | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]

5847 -- |

5948 -- A binder which matches a record and binds its properties

6049 --

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

@@ -60,7 +60,7 @@ data DeclarationRef

6060 -- |

6161 -- A type constructor with data constructors

6262 --

63− = TypeRef ProperName (Maybe [ProperName])

63+ = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])

6464 -- |

6565 -- A value

6666 --

@@ -68,7 +68,7 @@ data DeclarationRef

6868 -- |

6969 -- A type class

7070 --

71− | TypeClassRef ProperName

71+ | TypeClassRef (ProperName 'ClassName)

7272 -- |

7373 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

7474 --

@@ -80,7 +80,7 @@ data DeclarationRef

8080 -- |

8181 -- An unspecified ProperName ref. This will be replaced with a TypeClassRef

8282 -- or TypeRef during name desugaring.

83− | ProperRef ProperName

83+ | ProperRef String

8484 -- |

8585 -- A declaration reference with source position information

8686 --

@@ -108,7 +108,7 @@ isModuleRef _ = False

108108-- are the duplicate refs with data constructors elided, and then a separate

109109-- list of duplicate data constructors.

110110--

111−findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])

111+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])

112112findDuplicateRefs refs =

113113 let positionless = stripPosInfo `map` refs

114114 simplified = simplifyTypeRefs `map` positionless

@@ -154,7 +154,7 @@ data Declaration

154154 -- |

155155 -- A data type declaration (data or newtype, name, arguments, data constructors)

156156 --

157− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

157+ = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

158158 -- |

159159 -- A minimal mutually recursive set of data type declarations

160160 --

@@ -162,7 +162,7 @@ data Declaration

162162 -- |

163163 -- A type synonym declaration (name, arguments, type)

164164 --

165− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

165+ | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type

166166 -- |

167167 -- A type declaration for a value (name, ty)

168168 --

@@ -182,7 +182,7 @@ data Declaration

182182 -- |

183183 -- A data type foreign import (name, kind)

184184 --

185− | ExternDataDeclaration ProperName Kind

185+ | ExternDataDeclaration (ProperName 'TypeName) Kind

186186 -- |

187187 -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

188188 --

@@ -195,12 +195,12 @@ data Declaration

195195 -- |

196196 -- A type class declaration (name, argument, implies, member declarations)

197197 --

198− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]

198+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]

199199 -- |

200200 -- A type instance declaration (name, dependencies, class name, instance types, member

201201 -- declarations)

202202 --

203− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody

203+ | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody

204204 -- |

205205 -- A declaration with source position information

206206 --

@@ -390,7 +390,7 @@ data Expr

390390 -- |

391391 -- A data constructor

392392 --

393− | Constructor (Qualified ProperName)

393+ | Constructor (Qualified (ProperName 'ConstructorName))

394394 -- |

395395 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

396396 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

@@ -412,7 +412,7 @@ data Expr

412412 -- An application of a typeclass dictionary constructor. The value should be

413413 -- an ObjectLiteral.

414414 --

415− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

415+ | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr

416416 -- |

417417 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

418418 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

@@ -420,15 +420,15 @@ data Expr

420420 -- at superclass implementations when searching for a dictionary, the type class name and

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

422422 --

423− | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

423+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

424424 -- |

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

426426 --

427− | TypeClassDictionaryAccessor (Qualified ProperName) Ident

427+ | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident

428428 -- |

429429 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

430430 --

431− | SuperClassDictionary (Qualified ProperName) [Type]

431+ | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

432432 -- |

433433 -- A value with source position information

434434 --

src/Language/PureScript/AST/Exported.hs+36−21

@@ -1,8 +1,7 @@

1−

2−module Language.PureScript.AST.Exported (

3− exportedDeclarations,

4− isExported

5−) where

1+module Language.PureScript.AST.Exported

2+ ( exportedDeclarations

3+ , isExported

4+ ) where

76import Control.Category ((>>>))

87import Data.Maybe (mapMaybe)

@@ -23,12 +22,12 @@ import Language.PureScript.Names

2322-- instances will be incorrectly removed in some cases.

2423--

2524exportedDeclarations :: Module -> [Declaration]

26−exportedDeclarations (Module _ _ _ decls exps) = go decls

25+exportedDeclarations (Module _ _ mn decls exps) = go decls

2726 where

2827 go = flattenDecls

2928 >>> filter (isExported exps)

3029 >>> map (filterDataConstructors exps)

31− >>> filterInstances exps

30+ >>> filterInstances mn exps

3231

3332-- |

3433-- Filter out all data constructors from a declaration which are not exported.

@@ -52,10 +51,15 @@ filterDataConstructors _ other = other

5251-- produce incorrect results if this is not the case - for example, type class

5352-- instances will be incorrectly removed in some cases.

5453--

55−filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]

56−filterInstances Nothing = id

57−filterInstances (Just exps) =

58− let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps

54+filterInstances

55+ :: ModuleName

56+ -> Maybe [DeclarationRef]

57+ -> [Declaration]

58+ -> [Declaration]

59+filterInstances _ Nothing = id

60+filterInstances mn (Just exps) =

61+ let refs = Left `map` mapMaybe typeClassName exps

62+ ++ Right `map` mapMaybe typeName exps

5963 in filter (all (visibleOutside refs) . typeInstanceConstituents)

6064 where

6165 -- Given a Qualified ProperName, and a list of all exported types and type

@@ -65,13 +69,24 @@ filterInstances (Just exps) =

6569 -- * the name is defined in the same module and is exported,

6670 -- * the name is defined in a different module (and must be exported from

6771 -- that module; the code would fail to compile otherwise).

68− visibleOutside _ (Qualified (Just _) _) = True

69− visibleOutside refs (Qualified Nothing n) = n `elem` refs

70−

72+ visibleOutside

73+ :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]

74+ -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))

75+ -> Bool

76+ visibleOutside refs q

77+ | either checkQual checkQual q = True

78+ | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs

79+

80+ -- Check that a qualified name is qualified for a different module

81+ checkQual :: Qualified a -> Bool

82+ checkQual q = isQualified q && not (isQualifiedWith mn q)

83+

84+ typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)

7185 typeName (TypeRef n _) = Just n

7286 typeName (PositionedDeclarationRef _ _ r) = typeName r

7387 typeName _ = Nothing

7488

89+ typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)

7590 typeClassName (TypeClassRef n) = Just n

7691 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

7792 typeClassName _ = Nothing

@@ -79,17 +94,17 @@ filterInstances (Just exps) =

7994-- |

8095-- Get all type and type class names referenced by a type instance declaration.

8196--

82−typeInstanceConstituents :: Declaration -> [Qualified ProperName]

97+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]

8398typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

84− className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

99+ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

85100 where

86101

87− fromConstraint (name, tys') = name : concatMap fromType tys'

102+ fromConstraint (name, tys') = Left name : concatMap fromType tys'

88103 fromType = everythingOnTypes (++) go

89104

90105 -- Note that type synonyms are disallowed in instance declarations, so

91106 -- we don't need to handle them here.

92− go (TypeConstructor n) = [n]

107+ go (TypeConstructor n) = [Right n]

93108 go (ConstrainedType cs _) = concatMap fromConstraint cs

94109 go _ = []

95110

@@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps

118133 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

119134 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

120135

121− matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'

122− matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'

136+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'

137+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'

123138

124139 matches (PositionedDeclaration _ _ d) r = d `matches` r

125140 matches d (PositionedDeclarationRef _ _ r) = d `matches` r

@@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps

129144-- Test if a data constructor for a given type is exported, given a module's

130145-- export list. Prefer 'exportedDeclarations' to this function, where possible.

131146--

132−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool

147+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool

133148isDctorExported _ Nothing _ = True

134149isDctorExported ident (Just exps) ctor = test `any` exps

135150 where

src/Language/PureScript/CoreFn/Binders.hs+5−16

@@ -1,20 +1,9 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CoreFn.Binders

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation for binders

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162{-# LANGUAGE DeriveFunctor #-}

173

4+-- |

5+-- The core functional representation for binders

6+--

187module Language.PureScript.CoreFn.Binders where

198

209import qualified Data.Data as D

@@ -39,9 +28,9 @@ data Binder a

3928 --

4029 | VarBinder a Ident

4130 -- |

42− -- A binder which matches a data constructor (type name, constructor name, binders)

31+ -- A binder which matches a data constructor

4332 --

44− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]

33+ | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]

4534 -- |

4635 -- A binder which binds its input to an identifier

4736 --

src/Language/PureScript/CoreFn/Desugar.hs+10−4

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

170170 -- |

171171 -- Gets metadata for data constructors.

172172 --

173− getConstructorMeta :: Qualified ProperName -> Meta

173+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta

174174 getConstructorMeta ctor =

175175 case lookupConstructor env ctor of

176176 (Newtype, _, _, _) -> IsNewtype

@@ -178,9 +178,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

178178 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

179179 in IsConstructor constructorType fields

180180 where

181− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int

181+

182+ numConstructors

183+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

184+ -> Int

182185 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

183− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

186+

187+ typeConstructor

188+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

189+ -> (ModuleName, ProperName 'TypeName)

184190 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

185191 typeConstructor _ = internalError "Invalid argument to typeConstructor"

186192

@@ -255,5 +261,5 @@ mkTypeClassConstructor ss com supers members =

255261-- |

256262-- Converts a ProperName to an Ident.

257263--

258−properToIdent :: ProperName -> Ident

264+properToIdent :: ProperName a -> Ident

259265properToIdent = Ident . runProperName

src/Language/PureScript/CoreFn/Expr.hs+4−15

@@ -1,20 +1,9 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CoreFn.Expr

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162{-# LANGUAGE DeriveFunctor #-}

173

4+-- |

5+-- The core functional representation

6+--

187module Language.PureScript.CoreFn.Expr where

198

209import Control.Arrow ((***))

@@ -36,7 +25,7 @@ data Expr a

3625 -- |

3726 -- A data constructor (type name, constructor name, field names)

3827 --

39− | Constructor a ProperName ProperName [Ident]

28+ | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]

4029 -- |

4130 -- A record property accessor

4231 --

src/Language/PureScript/Docs/Convert.hs+1−1

@@ -172,7 +172,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

172172 extractProperNames _ = []

173173

174174 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

175− classApp = foldl P.TypeApp (P.TypeConstructor className) tys

175+ classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys

176176convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =

177177 Just (Left ([title], AugmentFixity fixity))

178178convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =

src/Language/PureScript/Docs/Render.hs+4−4

@@ -97,12 +97,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

9797 where

9898 renderType' = renderTypeWithOptions opts

9999

100−renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

100+renderConstraint :: P.Constraint -> RenderedCode

101101renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

102102

103−renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

103+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode

104104renderConstraintWithOptions opts (pn, tys) =

105− renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys

105+ renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys

106106

107107renderConstraints :: [P.Constraint] -> Maybe RenderedCode

108108renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

@@ -119,7 +119,7 @@ renderConstraintsWithOptions opts constraints

119119 mintersperse (syntax "," <> sp)

120120 (map (renderConstraintWithOptions opts) constraints)

121121

122−notQualified :: String -> P.Qualified P.ProperName

122+notQualified :: String -> P.Qualified (P.ProperName a)

123123notQualified = P.Qualified Nothing . P.ProperName

124124

125125typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type

src/Language/PureScript/Docs/RenderedCode/Render.hs+3−2

@@ -52,9 +52,10 @@ typeLiterals = mkPattern match

5252 ]

5353 where

5454 constraints = mintersperse (syntax "," <> sp) (map renderDep deps)

55+ renderDep :: Constraint -> RenderedCode

5556 renderDep (pn, tys) =

56− let instApp = foldl TypeApp (TypeConstructor pn) tys

57− in renderType instApp

57+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys

58+ in renderType instApp

5859 match REmpty =

5960 Just (syntax "()")

6061 match row@RCons{} =

src/Language/PureScript/Docs/Types.hs+1−1

@@ -399,7 +399,7 @@ asConstraint :: Parse PackageError P.Constraint

399399asConstraint = (,) <$> nth 0 asQualifiedProperName

400400 <*> nth 1 (eachInArray asType)

401401

402−asQualifiedProperName :: Parse e (P.Qualified P.ProperName)

402+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

403403asQualifiedProperName = fromAesonParser

404404

405405asQualifiedIdent :: Parse e (P.Qualified P.Ident)

src/Language/PureScript/Environment.hs+11−25

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Environment

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162{-# LANGUAGE OverloadedStrings #-}

173{-# LANGUAGE TemplateHaskell #-}

@@ -43,23 +29,23 @@ data Environment = Environment {

4329 -- |

4430 -- Type names currently in scope

4531 --

46− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)

32+ , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

4733 -- |

4834 -- Data constructors currently in scope, along with their associated type

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

50− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

36+ , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

5137 -- |

5238 -- Type synonyms currently in scope

5339 --

54− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)

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

5541 -- |

5642 -- Available type class dictionaries

5743 --

58− , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

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

5945 -- |

6046 -- Type classes

6147 --

62− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

48+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

6349 } deriving (Show, Read)

6450

6551-- |

@@ -107,7 +93,7 @@ data TypeKind

10793 -- |

10894 -- Data type

10995 --

110− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]

96+ = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

11197 -- |

11298 -- Type synonym

11399 --

@@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where

156142-- |

157143-- Construct a ProperName in the Prim module

158144--

159−primName :: String -> Qualified ProperName

145+primName :: String -> Qualified (ProperName a)

160146primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

161147

162148-- |

@@ -240,7 +226,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)

240226-- associated kinds. There is also a pseudo `Partial` type that corresponds to

241227-- the class with the same name.

242228--

243−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

229+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

244230primTypes =

245231 M.fromList

246232 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

@@ -258,7 +244,7 @@ primTypes =

258244-- The primitive class map. This just contains to `Partial` class, used as a

259245-- kind of magic constraint for partial functions.

260246--

261−primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

247+primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

262248primClasses =

263249 M.fromList

264250 [ (primName "Partial", ([], [], [])) ]

@@ -266,14 +252,14 @@ primClasses =

266252-- |

267253-- Finds information about data constructors from the current environment.

268254--

269−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

255+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])

270256lookupConstructor env ctor =

271257 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

272258

273259-- |

274260-- Checks whether a data constructor is for a newtype.

275261--

276−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

262+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool

277263isNewtypeConstructor e ctor = case lookupConstructor e ctor of

278264 (Newtype, _, _, _) -> True

279265 (Data, _, _, _) -> False

src/Language/PureScript/Errors.hs+41−41

@@ -53,63 +53,63 @@ data SimpleErrorMessage

5353 | RedefinedIdent Ident

5454 | OverlappingNamesInLet

5555 | UnknownModule ModuleName

56− | UnknownType (Qualified ProperName)

57− | UnknownTypeClass (Qualified ProperName)

56+ | UnknownType (Qualified (ProperName 'TypeName))

57+ | UnknownTypeClass (Qualified (ProperName 'ClassName))

5858 | UnknownValue (Qualified Ident)

59− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

60− | UnknownTypeConstructor (Qualified ProperName)

61− | UnknownImportType ModuleName ProperName

62− | UnknownExportType ProperName

63− | UnknownImportTypeClass ModuleName ProperName

64− | UnknownExportTypeClass ProperName

59+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

60+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

61+ | UnknownImportType ModuleName (ProperName 'TypeName)

62+ | UnknownExportType (ProperName 'TypeName)

63+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

64+ | UnknownExportTypeClass (ProperName 'ClassName)

6565 | UnknownImportValue ModuleName Ident

6666 | UnknownExportValue Ident

6767 | UnknownExportModule ModuleName

68− | UnknownImportDataConstructor ModuleName ProperName ProperName

69− | UnknownExportDataConstructor ProperName ProperName

68+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

69+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

7070 | ScopeConflict String [ModuleName]

71− | ConflictingTypeDecls ProperName

72− | ConflictingCtorDecls ProperName

73− | TypeConflictsWithClass ProperName

74− | CtorConflictsWithClass ProperName

75− | ClassConflictsWithType ProperName

76− | ClassConflictsWithCtor ProperName

71+ | ConflictingTypeDecls (ProperName 'TypeName)

72+ | ConflictingCtorDecls (ProperName 'ConstructorName)

73+ | TypeConflictsWithClass (ProperName 'TypeName)

74+ | CtorConflictsWithClass (ProperName 'ConstructorName)

75+ | ClassConflictsWithType (ProperName 'ClassName)

76+ | ClassConflictsWithCtor (ProperName 'ClassName)

7777 | DuplicateModuleName ModuleName

78− | DuplicateClassExport ProperName

78+ | DuplicateClassExport (ProperName 'ClassName)

7979 | DuplicateValueExport Ident

8080 | DuplicateTypeArgument String

8181 | InvalidDoBind

8282 | InvalidDoLet

8383 | CycleInDeclaration Ident

84− | CycleInTypeSynonym (Maybe ProperName)

84+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

8585 | CycleInModules [ModuleName]

8686 | NameIsUndefined Ident

87− | UndefinedTypeVariable ProperName

88− | PartiallyAppliedSynonym (Qualified ProperName)

87+ | UndefinedTypeVariable (ProperName 'TypeName)

88+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

8989 | EscapedSkolem (Maybe Expr)

9090 | TypesDoNotUnify Type Type

9191 | KindsDoNotUnify Kind Kind

9292 | ConstrainedTypeUnified Type Type

93− | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]

94− | NoInstanceFound (Qualified ProperName) [Type]

95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]

96− | CannotDerive (Qualified ProperName) [Type]

97− | CannotFindDerivingType ProperName

93+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

94+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]

95+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

96+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

97+ | CannotFindDerivingType (ProperName 'TypeName)

9898 | DuplicateLabel String (Maybe Expr)

9999 | DuplicateValueDeclaration Ident

100100 | ArgListLengthsDiffer Ident

101101 | OverlappingArgNames (Maybe Ident)

102102 | MissingClassMember Ident

103− | ExtraneousClassMember Ident (Qualified ProperName)

103+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

104104 | ExpectedType Type Kind

105− | IncorrectConstructorArity (Qualified ProperName)

105+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

106106 | ExprDoesNotHaveType Expr Type

107107 | PropertyIsMissing String

108108 | AdditionalProperty String

109109 | CannotApplyFunction Type Expr

110110 | TypeSynonymInstance

111− | OrphanInstance Ident (Qualified ProperName) [Type]

112− | InvalidNewtype ProperName

111+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

112+ | InvalidNewtype (ProperName 'TypeName)

113113 | InvalidInstanceHead Type

114114 | TransitiveExportError DeclarationRef [DeclarationRef]

115115 | ShadowedName Ident

@@ -120,17 +120,17 @@ data SimpleErrorMessage

120120 | NotExhaustivePattern [[Binder]] Bool

121121 | OverlappingPattern [[Binder]] Bool

122122 | IncompleteExhaustivityCheck

123− | ClassOperator ProperName Ident

124− | MisleadingEmptyTypeImport ModuleName ProperName

123+ | ClassOperator (ProperName 'ClassName) Ident

124+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

125125 | ImportHidingModule ModuleName

126126 | UnusedImport ModuleName

127127 | UnusedExplicitImport ModuleName [String]

128− | UnusedDctorImport ProperName

129− | UnusedDctorExplicitImport ProperName [ProperName]

128+ | UnusedDctorImport (ProperName 'TypeName)

129+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130130 | DeprecatedOperatorDecl String

131131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132− | DeprecatedClassImport ModuleName ProperName

133− | DeprecatedClassExport ProperName

132+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133+ | DeprecatedClassExport (ProperName 'ClassName)

134134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135135 | DuplicateSelectiveImport ModuleName

136136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

@@ -139,7 +139,7 @@ data SimpleErrorMessage

139139 | IntOutOfRange Integer String Integer Integer

140140 | RedundantEmptyHidingImport ModuleName

141141 | ImplicitImport ModuleName [DeclarationRef]

142− | ImplicitDctorImport ProperName [ProperName]

142+ | ImplicitDctorImport (ProperName 'TypeName) [ProperName 'ConstructorName]

143143 | CaseBinderLengthDiffers Int [Binder]

144144 deriving (Show)

145145

@@ -148,7 +148,7 @@ data ErrorMessageHint

148148 = ErrorUnifyingTypes Type Type

149149 | ErrorInExpression Expr

150150 | ErrorInModule ModuleName

151− | ErrorInInstance (Qualified ProperName) [Type]

151+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

152152 | ErrorInSubsumption Type Type

153153 | ErrorCheckingAccessor Expr String

154154 | ErrorCheckingType Expr Type

@@ -156,11 +156,11 @@ data ErrorMessageHint

156156 | ErrorCheckingGuard

157157 | ErrorInferringType Expr

158158 | ErrorInApplication Expr Type Expr

159− | ErrorInDataConstructor ProperName

160− | ErrorInTypeConstructor ProperName

159+ | ErrorInDataConstructor (ProperName 'ConstructorName)

160+ | ErrorInTypeConstructor (ProperName 'TypeName)

161161 | ErrorInBindingGroup [Ident]

162162 | ErrorInDataBindingGroup

163− | ErrorInTypeSynonym ProperName

163+ | ErrorInTypeSynonym (ProperName 'TypeName)

164164 | ErrorInValueDeclaration Ident

165165 | ErrorInTypeDeclaration Ident

166166 | ErrorInForeignImport Ident

@@ -1010,7 +1010,7 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

10101010 prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

10111011 prettyPrintRef (ValueRef ident) = showIdent ident

10121012 prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1013− prettyPrintRef (ProperRef pn) = runProperName pn

1013+ prettyPrintRef (ProperRef name) = name

10141014 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

10151015 prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

10161016 prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

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

@@ -80,21 +80,21 @@ data ExternsFixity = ExternsFixity

8080data ExternsDeclaration =

8181 -- | A type declaration

8282 EDType

83− { edTypeName :: ProperName

83+ { edTypeName :: ProperName 'TypeName

8484 , edTypeKind :: Kind

8585 , edTypeDeclarationKind :: TypeKind

8686 }

8787 -- | A type synonym

8888 | EDTypeSynonym

89− { edTypeSynonymName :: ProperName

89+ { edTypeSynonymName :: ProperName 'TypeName

9090 , edTypeSynonymArguments :: [(String, Maybe Kind)]

9191 , edTypeSynonymType :: Type

9292 }

9393 -- | A data construtor

9494 | EDDataConstructor

95− { edDataCtorName :: ProperName

95+ { edDataCtorName :: ProperName 'ConstructorName

9696 , edDataCtorOrigin :: DataDeclType

97− , edDataCtorTypeCtor :: ProperName

97+ , edDataCtorTypeCtor :: ProperName 'TypeName

9898 , edDataCtorType :: Type

9999 , edDataCtorFields :: [Ident]

100100 }

@@ -105,14 +105,14 @@ data ExternsDeclaration =

105105 }

106106 -- | A type class declaration

107107 | EDClass

108− { edClassName :: ProperName

108+ { edClassName :: ProperName 'ClassName

109109 , edClassTypeArguments :: [(String, Maybe Kind)]

110110 , edClassMembers :: [(Ident, Type)]

111111 , edClassConstraints :: [Constraint]

112112 }

113113 -- | An instance declaration

114114 | EDInstance

115− { edInstanceClassName :: Qualified ProperName

115+ { edInstanceClassName :: Qualified (ProperName 'ClassName)

116116 , edInstanceName :: Ident

117117 , edInstanceTypes :: [Type]

118118 , edInstanceConstraints :: Maybe [Constraint]

@@ -178,7 +178,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

178178 Just (kind, tk@(DataType _ tys)) ->

179179 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

180180 | dctor <- fromMaybe (map fst tys) dctors

181− , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

181+ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)

182182 ]

183183 _ -> internalError "toExternsDeclaration: Invalid input"

184184 toExternsDeclaration (ValueRef ident)

@@ -186,10 +186,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

186186 = [ EDValue ident ty ]

187187 toExternsDeclaration (TypeClassRef className)

188188 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

189− , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)

190− , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env

191− = [ EDType className kind TypeSynonym

192− , EDTypeSynonym className args synTy

189+ , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env

190+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env

191+ = [ EDType (coerceProperName className) kind TypeSynonym

192+ , EDTypeSynonym (coerceProperName className) args synTy

193193 , EDClass className args members implies

194194 ]

195195 toExternsDeclaration (TypeInstanceRef ident)

src/Language/PureScript/Linter/Exhaustive.hs+28−39

@@ -1,24 +1,12 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Exhaustive

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- | Module for exhaustivity checking over pattern matching definitions

13−-- | The algorithm analyses the clauses of a definition one by one from top

14−-- | to bottom, where in each step it has the cases already missing (uncovered),

15−-- | and it generates the new set of missing cases.

16−--

17−-----------------------------------------------------------------------------

18−

191{-# LANGUAGE FlexibleContexts #-}

202{-# LANGUAGE ScopedTypeVariables #-}

213

4+-- |

5+-- Module for exhaustivity checking over pattern matching definitions

6+-- The algorithm analyses the clauses of a definition one by one from top

7+-- to bottom, where in each step it has the cases already missing (uncovered),

8+-- and it generates the new set of missing cases.

9+--

2210module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

2311

2412import Prelude ()

@@ -54,7 +42,11 @@ data RedudancyError = Incomplete | Unknown

5442-- |

5543-- Qualifies a propername from a given qualified propername and a default module name

5644--

57−qualifyName :: a -> ModuleName -> Qualified a -> Qualified a

45+qualifyName

46+ :: (ProperName a)

47+ -> ModuleName

48+ -> Qualified (ProperName b)

49+ -> Qualified (ProperName a)

5850qualifyName n defmn qn = Qualified (Just mn) n

5951 where

6052 (mn, _) = qualify defmn qn

@@ -65,31 +57,28 @@ qualifyName n defmn qn = Qualified (Just mn) n

6557-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

6658-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

6759--

68−getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

60+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]

6961getConstructors env defmn n = extractConstructors lnte

7062 where

71− qpn :: Qualified ProperName

72− qpn = getConsDataName n

7363

74− getConsDataName :: Qualified ProperName -> Qualified ProperName

75− getConsDataName con = qualifyName nm defmn con

76− where

77− nm = case getConsInfo con of

78− Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

79− Just (_, pm, _, _) -> pm

80−

81− getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])

82− getConsInfo con = M.lookup con dce

83− where

84− dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

85− dce = dataConstructors env

64+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]

65+ extractConstructors (Just (_, DataType _ pt)) = pt

66+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

8667

8768 lnte :: Maybe (Kind, TypeKind)

8869 lnte = M.lookup qpn (types env)

8970

90− extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

91− extractConstructors (Just (_, DataType _ pt)) = pt

92− extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

71+ qpn :: Qualified (ProperName 'TypeName)

72+ qpn = getConsDataName n

73+

74+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

75+ getConsDataName con =

76+ case getConsInfo con of

77+ Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

78+ Just (_, pm, _, _) -> qualifyName pm defmn con

79+

80+ getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])

81+ getConsInfo con = M.lookup con (dataConstructors env)

9382

9483-- |

9584-- Replicates a wildcard binder

@@ -303,14 +292,14 @@ checkExhaustiveDecls env mn = mapM_ onDecl

303292 hasPartialConstraint :: Type -> Bool

304293 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

305294 where

306− go :: Qualified ProperName -> Bool

295+ go :: Qualified (ProperName 'ClassName) -> Bool

307296 go qname

308297 | qname == partialClass = True

309298 | otherwise =

310299 case qname `M.lookup` typeClasses env of

311300 Just ([], _, cs') -> any (go . fst) cs'

312301 _ -> False

313− partialClass :: Qualified ProperName

302+ partialClass :: Qualified (ProperName 'ClassName)

314303 partialClass = primName "Partial"

315304 hasPartialConstraint _ = False

316305

src/Language/PureScript/Linter/Imports.hs+21−17

@@ -28,21 +28,21 @@ import qualified Language.PureScript.Constants as C

2828-- | Imported name used in some type or expression.

2929data Name

3030 = IdentName (Qualified Ident)

31− | TypeName (Qualified ProperName)

32− | DctorName (Qualified ProperName)

33− | ClassName (Qualified ProperName)

31+ | TyName (Qualified (ProperName 'TypeName))

32+ | DctorName (Qualified (ProperName 'ConstructorName))

33+ | TyClassName (Qualified (ProperName 'ClassName))

3434 deriving (Eq)

3535

3636getIdentName :: Name -> Maybe Ident

3737getIdentName (IdentName (Qualified _ name)) = Just name

3838getIdentName _ = Nothing

3939

40−getTypeName :: Name -> Maybe ProperName

41−getTypeName (TypeName (Qualified _ name)) = Just name

40+getTypeName :: Name -> Maybe (ProperName 'TypeName)

41+getTypeName (TyName (Qualified _ name)) = Just name

4242getTypeName _ = Nothing

4343

44−getClassName :: Name -> Maybe ProperName

45−getClassName (ClassName (Qualified _ name)) = Just name

44+getClassName :: Name -> Maybe (ProperName 'ClassName)

45+getClassName (TyClassName (Qualified _ name)) = Just name

4646getClassName _ = Nothing

4747

4848-- | Map of module name to list of imported names from that module which have been used.

@@ -96,12 +96,12 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

9696

9797 _ -> return ()

9898 where

99− reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]

99+ reconstructTypeRefs :: ModuleName -> [ProperName 'ConstructorName] -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

100100 reconstructTypeRefs mni = foldr accumDctors M.empty

101101 where

102102 accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

103103

104− findTypeForDctor :: ModuleName -> ProperName -> ProperName

104+ findTypeForDctor :: ModuleName -> ProperName 'ConstructorName -> ProperName 'TypeName

105105 findTypeForDctor mn dctor =

106106 case mn `M.lookup` env of

107107 Just (_, _, exps) ->

@@ -122,17 +122,17 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

122122 qnameUsed (Just qn) = qn `elem` alwaysUsedModules

123123 qnameUsed Nothing = False

124124

125− dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]

125+ dtys :: ModuleName -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

126126 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

127127

128− dctorsForType :: ModuleName -> ProperName -> [ProperName]

128+ dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName]

129129 dctorsForType mn tn =

130130 maybe [] getDctors (find matches $ dtys mn)

131131 where

132132 matches ((ty, _),_) = ty == tn

133133 getDctors ((_,ctors),_) = ctors

134134

135− typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

135+ typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)

136136 typeForDCtor mn pn =

137137 getTy <$> find matches (dtys mn)

138138 where

@@ -140,14 +140,18 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

140140 getTy ((ty, _), _) = ty

141141

142142

143−matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

143+matchName

144+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

145+ -> Maybe ModuleName

146+ -> Name

147+ -> Maybe String

144148matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

145−matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x

146−matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x

149+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

150+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

147151matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

148152matchName _ _ _ = Nothing

149153

150−matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName

154+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)

151155matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

152156matchDctor _ _ = Nothing

153157

@@ -158,7 +162,7 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

158162runDeclRef (TypeClassRef pn) = Just $ runProperName pn

159163runDeclRef _ = Nothing

160164

161−getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])

165+getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

162166getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

163167getTypeRef (TypeRef pn x) = Just (pn, x)

164168getTypeRef _ = Nothing

src/Language/PureScript/Make.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

21{-# LANGUAGE FlexibleContexts #-}

32{-# LANGUAGE GeneralizedNewtypeDeriving #-}

43{-# LANGUAGE TupleSections #-}

src/Language/PureScript/Names.hs+40−6

@@ -1,7 +1,8 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE DeriveFunctor #-}

33{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE EmptyDataDecls #-}

5+{-# LANGUAGE KindSignatures #-}

67-- |

78-- Data types for names

@@ -13,6 +14,7 @@ import Control.Monad.Supply.Class

1314

1415import Data.List

1516import Data.Data

17+import Data.Aeson

1618import Data.Aeson.TH

1719

1820-- |

@@ -51,12 +53,32 @@ freshIdent' = liftM (GenIdent Nothing) fresh

5153-- |

5254-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

5355--

54−newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)

56+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }

57+ deriving (Show, Read, Eq, Ord, Data, Typeable)

58+

59+instance ToJSON (ProperName a) where

60+ toJSON = toJSON . runProperName

61+

62+instance FromJSON (ProperName a) where

63+ parseJSON = fmap ProperName . parseJSON

64+

65+-- |

66+-- The closed set of proper name types.

67+--

68+data ProperNameType = TypeName | ConstructorName | ClassName | Namespace

69+

70+-- |

71+-- Coerces a ProperName from one ProperNameType to another. This should be used

72+-- with care, and is primarily used to convert ClassNames into TypeNames after

73+-- classes have been desugared.

74+--

75+coerceProperName :: ProperName a -> ProperName b

76+coerceProperName = ProperName . runProperName

5577

5678-- |

5779-- Module names

5880--

59−newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)

81+newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Read, Eq, Ord, Data, Typeable)

6082

6183runModuleName :: ModuleName -> String

6284runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

@@ -98,11 +120,23 @@ disqualify (Qualified _ a) = a

98120-- |

99121-- Checks whether a qualified value is actually qualified with a module reference

100122--

123+isQualified :: Qualified a -> Bool

124+isQualified (Qualified Nothing _) = False

125+isQualified _ = True

126+

127+-- |

128+-- Checks whether a qualified value is not actually qualified with a module reference

129+--

101130isUnqualified :: Qualified a -> Bool

102−isUnqualified (Qualified Nothing _) = True

103−isUnqualified _ = False

131+isUnqualified = not . isQualified

132+

133+-- |

134+-- Checks whether a qualified value is qualified with a particular module

135+--

136+isQualifiedWith :: ModuleName -> Qualified a -> Bool

137+isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'

138+isQualifiedWith _ _ = False

104139

105140$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)

106141$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

107−$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)

108142$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

src/Language/PureScript/Parser/Common.hs+3−15

@@ -1,20 +1,8 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Parser.Common

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

113-- |

124-- Constants, and utility functions to be used when parsing

135--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE FlexibleContexts #-}

17−

186module Language.PureScript.Parser.Common where

197

208import Control.Applicative

@@ -27,7 +15,7 @@ import Language.PureScript.Names

2715

2816import qualified Text.Parsec as P

2917

30−properName :: TokenParser ProperName

18+properName :: TokenParser (ProperName a)

3119properName = ProperName <$> uname

3220

3321-- |

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

@@ -165,7 +165,7 @@ parseDeclarationRef =

165165 parseProperRef = do

166166 name <- properName

167167 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

168− return $ maybe (ProperRef name) (TypeRef name) dctors

168+ return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors

169169

170170parseTypeClassDeclaration :: TokenParser Declaration

171171parseTypeClassDeclaration = do

src/Language/PureScript/Pretty/Types.hs+10−22

@@ -1,26 +1,14 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Pretty.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

111-- |

122-- Pretty printer for Types

133--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.Pretty.Types (

17− typeAsBox,

18− prettyPrintType,

19− typeAtomAsBox,

20− prettyPrintTypeAtom,

21− prettyPrintRowWith,

22− prettyPrintRow

23−) where

4+module Language.PureScript.Pretty.Types

5+ ( typeAsBox

6+ , prettyPrintType

7+ , typeAtomAsBox

8+ , prettyPrintTypeAtom

9+ , prettyPrintRowWith

10+ , prettyPrintRow

11+ ) where

2412

2513import Data.Maybe (fromMaybe)

2614

@@ -50,11 +38,11 @@ typeLiterals = mkPattern match

5038 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

5139 match _ = Nothing

5240

53−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

41+constraintsAsBox :: [Constraint] -> Box -> Box

5442constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

5543constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

5644

57−constraintAsBox :: Qualified ProperName -> [Type] -> Box

45+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box

5846constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

5947

6048-- |

src/Language/PureScript/Sugar/BindingGroups.hs+73−55

@@ -1,60 +1,61 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.BindingGroups

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE LambdaCase #-}

115-- |

126-- This module implements the desugaring pass which creates binding groups from sets of

137-- mutually-recursive value declarations and mutually-recursive type declarations.

148--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20−module Language.PureScript.Sugar.BindingGroups (

21− createBindingGroups,

22− createBindingGroupsModule,

23− collapseBindingGroups,

24− collapseBindingGroupsModule

25−) where

9+module Language.PureScript.Sugar.BindingGroups

10+ ( createBindingGroups

11+ , createBindingGroupsModule

12+ , collapseBindingGroups

13+ , collapseBindingGroupsModule

14+ ) where

2615

2716import Prelude ()

2817import Prelude.Compat

2918

30−import Data.Graph

31−import Data.List (nub, intersect)

32−import Data.Maybe (isJust, mapMaybe)

3319import Control.Monad ((<=<))

3420import Control.Monad.Error.Class (MonadError(..))

3521

22+import Data.Graph

23+import Data.List (nub, intersect)

24+import Data.Maybe (isJust, mapMaybe)

3625import qualified Data.Set as S

3726

38−import Language.PureScript.Crash

3927import Language.PureScript.AST

40−import Language.PureScript.Names

41−import Language.PureScript.Types

28+import Language.PureScript.Crash

4229import Language.PureScript.Environment

4330import Language.PureScript.Errors

31+import Language.PureScript.Names

32+import Language.PureScript.Types

4433

4534-- |

4635-- Replace all sets of mutually-recursive declarations in a module with binding groups

4736--

48−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

49−createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps

37+createBindingGroupsModule

38+ :: (Functor m, Applicative m, MonadError MultipleErrors m)

39+ => [Module]

40+ -> m [Module]

41+createBindingGroupsModule =

42+ mapM $ \(Module ss coms name ds exps) ->

43+ Module ss coms name <$> createBindingGroups name ds <*> pure exps

5044

5145-- |

5246-- Collapse all binding groups in a module to individual declarations

5347--

5448collapseBindingGroupsModule :: [Module] -> [Module]

55−collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

56−

57−createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

49+collapseBindingGroupsModule =

50+ map $ \(Module ss coms name ds exps) ->

51+ Module ss coms name (collapseBindingGroups ds) exps

52+

53+createBindingGroups

54+ :: forall m

55+ . (Functor m, Applicative m, MonadError MultipleErrors m)

56+ => ModuleName

57+ -> [Declaration]

58+ -> m [Declaration]

5859createBindingGroups moduleName = mapM f <=< handleDecls

5960

6061 where

@@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls

7172 handleDecls ds = do

7273 let values = filter isValueDecl ds

7374 dataDecls = filter isDataDecl ds

74− allProperNames = map getProperName dataDecls

75− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

75+ allProperNames = map getTypeName dataDecls

76+ dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls

7677 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

7778 let allIdents = map getIdent values

7879 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

@@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls

9091-- Collapse all binding groups to individual declarations

9192--

9293collapseBindingGroups :: [Declaration] -> [Declaration]

93−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go

94+collapseBindingGroups =

95+ let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id

96+ in map f . concatMap go

9497 where

9598 go (DataBindingGroupDeclaration ds) = ds

96− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

97− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d

99+ go (BindingGroupDeclaration ds) =

100+ map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

101+ go (PositionedDeclaration pos com d) =

102+ map (PositionedDeclaration pos com) $ go d

98103 go other = [other]

99104

100105collapseBindingGroupsForValue :: Expr -> Expr

@@ -114,8 +119,10 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue

114119 (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

115120

116121 usedNamesE :: S.Set Ident -> Expr -> [Ident]

117− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]

118− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]

122+ usedNamesE scope (Var (Qualified Nothing name))

123+ | name `S.notMember` scope = [name]

124+ usedNamesE scope (Var (Qualified (Just moduleName') name))

125+ | moduleName == moduleName' && name `S.notMember` scope = [name]

119126 usedNamesE _ _ = []

120127

121128usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

@@ -127,21 +134,24 @@ usedImmediateIdents moduleName =

127134

128135 usedNamesE :: Bool -> Expr -> (Bool, [Ident])

129136 usedNamesE True (Var (Qualified Nothing name)) = (True, [name])

130− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])

137+ usedNamesE True (Var (Qualified (Just moduleName') name))

138+ | moduleName == moduleName' = (True, [name])

131139 usedNamesE True (Abs _ _) = (False, [])

132140 usedNamesE scope _ = (scope, [])

133141

134−usedProperNames :: ModuleName -> Declaration -> [ProperName]

135−usedProperNames moduleName =

142+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]

143+usedTypeNames moduleName =

136144 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

137145 in nub . f

138146 where

139− usedNames :: Type -> [ProperName]

140− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->

141− case qual of

142− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name

147+ usedNames :: Type -> [ProperName 'TypeName]

148+ usedNames (ConstrainedType constraints _) =

149+ flip mapMaybe constraints $ \case

150+ (Qualified (Just moduleName') name, _)

151+ | moduleName == moduleName' -> Just (coerceProperName name)

143152 _ -> Nothing

144− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

153+ usedNames (TypeConstructor (Qualified (Just moduleName') name))

154+ | moduleName == moduleName' = [name]

145155 usedNames _ = []

146156

147157getIdent :: Declaration -> Ident

@@ -149,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident

149159getIdent (PositionedDeclaration _ _ d) = getIdent d

150160getIdent _ = internalError "Expected ValueDeclaration"

151161

152−getProperName :: Declaration -> ProperName

153−getProperName (DataDeclaration _ pn _ _) = pn

154−getProperName (TypeSynonymDeclaration pn _ _) = pn

155−getProperName (PositionedDeclaration _ _ d) = getProperName d

156−getProperName _ = internalError "Expected DataDeclaration"

162+getTypeName :: Declaration -> ProperName 'TypeName

163+getTypeName (DataDeclaration _ pn _ _) = pn

164+getTypeName (TypeSynonymDeclaration pn _ _) = pn

165+getTypeName (PositionedDeclaration _ _ d) = getTypeName d

166+getTypeName _ = internalError "Expected DataDeclaration"

157167

158168-- |

159169-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

160170--

161171--

162−toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

172+toBindingGroup

173+ :: forall m

174+ . (Functor m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> SCC Declaration

177+ -> m Declaration

163178toBindingGroup _ (AcyclicSCC d) = return d

164179toBindingGroup moduleName (CyclicSCC ds') =

165180 -- Once we have a mutually-recursive group of declarations, we need to sort

@@ -188,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') =

188203 cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

189204 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

190205

191−toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

206+toDataBindingGroup

207+ :: MonadError MultipleErrors m

208+ => SCC Declaration

209+ -> m Declaration

192210toDataBindingGroup (AcyclicSCC d) = return d

193211toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

194212 Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

@@ -197,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds')

197215 | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

198216 | otherwise = return $ DataBindingGroupDeclaration ds'

199217

200−isTypeSynonym :: Declaration -> Maybe ProperName

218+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)

201219isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

202220isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

203221isTypeSynonym _ = Nothing

src/Language/PureScript/Sugar/Names.hs+59−22

@@ -56,17 +56,17 @@ desugarImports externs modules = do

5656 return $ M.insert efModuleName (ss, imps, exps) env

5757 where

5858

59− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

59+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

6060 exportedTypes = mapMaybe toExportedType efExports

6161 where

6262 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

6363 where

64− forTyCon :: ExternsDeclaration -> Maybe ProperName

64+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

6565 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

6666 forTyCon _ = Nothing

6767 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

6868 toExportedType _ = Nothing

69− exportedTypeClasses :: [(ProperName, ModuleName)]

69+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

7070 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

7171 where

7272 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

@@ -120,14 +120,23 @@ elaborateExports exps (Module ss coms mn decls refs) =

120120-- Replaces all local names with qualified names within a module and checks that all existing

121121-- qualified names are valid.

122122--

123−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module

123+renameInModule

124+ :: forall m

125+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

126+ => Env

127+ -> Imports

128+ -> Module

129+ -> m Module

124130renameInModule env imports (Module ss coms mn decls exps) =

125131 Module ss coms mn <$> parU decls go <*> pure exps

126132 where

127133

128134 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

129135

130− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

136+ updateDecl

137+ :: (Maybe SourceSpan, [Ident])

138+ -> Declaration

139+ -> m ((Maybe SourceSpan, [Ident]), Declaration)

131140 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

132141 return ((Just pos, bound), d)

133142 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

@@ -146,7 +155,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

146155 (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)

147156 updateDecl s d = return (s, d)

148157

149− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

158+ updateValue

159+ :: (Maybe SourceSpan, [Ident])

160+ -> Expr

161+ -> m ((Maybe SourceSpan, [Ident]), Expr)

150162 updateValue (_, bound) v@(PositionedValue pos' _ _) =

151163 return ((Just pos', bound), v)

152164 updateValue (pos, bound) (Abs (Left arg) val') =

@@ -167,7 +179,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

167179 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

168180 updateValue s v = return (s, v)

169181

170− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

182+ updateBinder

183+ :: (Maybe SourceSpan, [Ident])

184+ -> Binder

185+ -> m ((Maybe SourceSpan, [Ident]), Binder)

171186 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

172187 return ((Just pos, bound), v)

173188 updateBinder s@(pos, _) (ConstructorBinder name b) =

@@ -179,7 +194,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

179194 updateBinder s v =

180195 return (s, v)

181196

182− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

197+ updateCase

198+ :: (Maybe SourceSpan, [Ident])

199+ -> CaseAlternative

200+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

183201 updateCase (pos, bound) c@(CaseAlternative bs _) =

184202 return ((pos, concatMap binderNames bs ++ bound), c)

185203

@@ -199,16 +217,25 @@ renameInModule env imports (Module ss coms mn decls exps) =

199217 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

200218 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

201219

202− updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

203− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

220+ updateTypeName

221+ :: Qualified (ProperName 'TypeName)

222+ -> Maybe SourceSpan

223+ -> m (Qualified (ProperName 'TypeName))

224+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)

204225

205− updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

226+ updateDataConstructorName

227+ :: Qualified (ProperName 'ConstructorName)

228+ -> Maybe SourceSpan

229+ -> m (Qualified (ProperName 'ConstructorName))

206230 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

207231

208− updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

209− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

232+ updateClassName

233+ :: Qualified (ProperName 'ClassName)

234+ -> Maybe SourceSpan

235+ -> m (Qualified (ProperName 'ClassName))

236+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)

210237

211− updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

238+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

212239 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

213240

214241 -- Used when performing an update to qualify values and classes with their

@@ -218,12 +245,18 @@ renameInModule env imports (Module ss coms mn decls exps) =

218245

219246 -- Used when performing an update to qualify types with their module of

220247 -- original definition.

221− resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

248+ resolveType

249+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

250+ -> ProperName 'TypeName

251+ -> Maybe (Qualified (ProperName 'TypeName))

222252 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

223253

224254 -- Used when performing an update to qualify data constructors with their

225255 -- module of original definition.

226− resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

256+ resolveDctor

257+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

258+ -> ProperName 'ConstructorName

259+ -> Maybe (Qualified (ProperName 'ConstructorName))

227260 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

228261

229262 -- Update names so unqualified references become qualified, and locally

@@ -279,25 +312,29 @@ renameInModule env imports (Module ss coms mn decls exps) =

279312-- depending on what is availble within the module. Warns when a `ProperRef`

280313-- desugars into a `TypeClassRef`.

281314--

282−updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module

315+updateExportRefs

316+ :: forall m

317+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

318+ => Module

319+ -> m Module

283320updateExportRefs (Module ss coms mn decls exps) =

284321 Module ss coms mn decls <$> traverse (traverse updateRef) exps

285322 where

286323

287324 updateRef :: DeclarationRef -> m DeclarationRef

288325 updateRef (ProperRef name)

289− | name `elem` classNames = do

290− tell . errorMessage $ DeprecatedClassExport name

291− return $ TypeClassRef name

326+ | ProperName name `elem` classNames = do

327+ tell . errorMessage . DeprecatedClassExport $ ProperName name

328+ return . TypeClassRef $ ProperName name

292329 -- Fall through case here - assume it's a type if it's not a class.

293330 -- If it's a reference to something that doesn't actually exist it will

294331 -- be picked up elsewhere

295− | otherwise = return $ TypeRef name (Just [])

332+ | otherwise = return $ TypeRef (ProperName name) (Just [])

296333 updateRef (PositionedDeclarationRef pos com ref) =

297334 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

298335 updateRef other = return other

299336

300− classNames :: [ProperName]

337+ classNames :: [ProperName 'ClassName]

301338 classNames = mapMaybe go decls

302339 where

303340 go (PositionedDeclaration _ _ d) = go d

src/Language/PureScript/Sugar/Names/Env.hs+11−12

@@ -41,15 +41,15 @@ data Imports = Imports

4141 -- |

4242 -- Local names for types within a module mapped to to their qualified names

4343 --

44− importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

44+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]

4545 -- |

4646 -- Local names for data constructors within a module mapped to to their qualified names

4747 --

48− , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

48+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]

4949 -- |

5050 -- Local names for classes within a module mapped to to their qualified names

5151 --

52− , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

52+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]

5353 -- |

5454 -- Local names for values within a module mapped to to their qualified names

5555 --

@@ -80,12 +80,12 @@ data Exports = Exports

8080 -- The types exported from each module along with the module they originally

8181 -- came from.

8282 --

83− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

83+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

8484 -- |

8585 -- The classes exported from each module along with the module they originally

8686 -- came from.

8787 --

88− , exportedTypeClasses :: [(ProperName, ModuleName)]

88+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

8989 -- |

9090 -- The values exported from each module along with the module they originally

9191 -- came from.

@@ -143,29 +143,28 @@ primEnv = M.singleton

143143-- Safely adds a type and its data constructors to some exports, returning an

144144-- error if a conflict occurs.

145145--

146−exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

146+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports

147147exportType exps name dctors mn = do

148148 let exTypes' = exportedTypes exps

149149 let exTypes = filter ((/= mn) . snd) exTypes'

150150 let exDctors = (snd . fst) `concatMap` exTypes

151151 let exClasses = exportedTypeClasses exps

152−

153152 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

154− when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

153+ when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

155154 forM_ dctors $ \dctor -> do

156155 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

157− when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

156+ when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

158157 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

159158

160159-- |

161160-- Safely adds a class to some exports, returning an error if a conflict occurs.

162161--

163−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports

162+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

164163exportTypeClass exps name mn = do

165164 let exTypes = exportedTypes exps

166165 let exDctors = (snd . fst) `concatMap` exTypes

167− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

168− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

166+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

167+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

169168 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

170169 return $ exps { exportedTypeClasses = classes }

171170

src/Language/PureScript/Sugar/Names/Exports.hs+31−8

@@ -75,7 +75,7 @@ resolveExports env mn imps exps refs =

7575 ModuleRef name -> warnDupe $ "module " ++ runModuleName name

7676 _ -> return ()

7777

78− warnDupeDctors :: [ProperName] -> m ()

78+ warnDupeDctors :: [ProperName 'ConstructorName] -> m ()

7979 warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)

8080

8181 warnDupe :: String -> m ()

@@ -151,10 +151,15 @@ resolveExports env mn imps exps refs =

151151

152152 -- Constructs a list of types with their data constructors and the original

153153 -- module they were defined in from a list of type and data constructor names.

154− resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]

154+ resolveTypeExports

155+ :: [Qualified (ProperName 'TypeName)]

156+ -> [Qualified (ProperName 'ConstructorName)]

157+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

155158 resolveTypeExports tctors dctors = map go tctors

156159 where

157− go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

160+ go

161+ :: Qualified (ProperName 'TypeName)

162+ -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)

158163 go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159164 exps' <- envModuleExports <$> mn'' `M.lookup` env

160165 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

@@ -165,7 +170,7 @@ resolveExports env mn imps exps refs =

165170

166171 -- Looks up an imported class and re-qualifies it with the original module it

167172 -- came from.

168− resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

173+ resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)

169174 resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

170175 resolve exportedTypeClasses className

171176

@@ -192,7 +197,13 @@ resolveExports env mn imps exps refs =

192197-- Filters the full list of exportable values, types, and classes for a module

193198-- based on a list of export declaration references.

194199--

195−filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports

200+filterModule

201+ :: forall m

202+ . (Applicative m, MonadError MultipleErrors m)

203+ => ModuleName

204+ -> Exports

205+ -> [DeclarationRef]

206+ -> m Exports

196207filterModule mn exps refs = do

197208 types <- foldM (filterTypes $ exportedTypes exps) [] refs

198209 values <- foldM (filterValues $ exportedValues exps) [] refs

@@ -206,7 +217,11 @@ filterModule mn exps refs = do

206217 -- explicit export. When the ref refers to a type in the list of exportable

207218 -- values, the type and specified data constructors are included in the

208219 -- result.

209− filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]

220+ filterTypes

221+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

222+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

223+ -> DeclarationRef

224+ -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

210225 filterTypes exps' result (PositionedDeclarationRef pos _ r) =

211226 rethrowWithPosition pos $ filterTypes exps' result r

212227 filterTypes exps' result (TypeRef name expDcons) =

@@ -221,7 +236,11 @@ filterModule mn exps refs = do

221236 -- Ensures a data constructor is exportable for a given type. Takes a type

222237 -- name, a list of exportable data constructors for the type, and the name of

223238 -- the data constructor to check.

224− checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()

239+ checkDcon

240+ :: ProperName 'TypeName

241+ -> [ProperName 'ConstructorName]

242+ -> ProperName 'ConstructorName

243+ -> m ()

225244 checkDcon tcon exps' name =

226245 unless (name `elem` exps') $

227246 throwError . errorMessage $ UnknownExportDataConstructor tcon name

@@ -230,7 +249,11 @@ filterModule mn exps refs = do

230249 -- filtered exports, and a `DeclarationRef` for an explicit export. When the

231250 -- ref refers to a class in the list of exportable classes, the class is

232251 -- included in the result.

233− filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]

252+ filterClasses

253+ :: [(ProperName 'ClassName, ModuleName)]

254+ -> [(ProperName 'ClassName, ModuleName)]

255+ -> DeclarationRef

256+ -> m [(ProperName 'ClassName, ModuleName)]

234257 filterClasses exps' result (PositionedDeclarationRef pos _ r) =

235258 rethrowWithPosition pos $ filterClasses exps' result r

236259 filterClasses exps' result (TypeClassRef name) =

src/Language/PureScript/Sugar/Names/Imports.hs+19−10

@@ -124,7 +124,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

124124 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

125125 _ -> return ()

126126

127− warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()

127+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()

128128 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

129129

130130 warnDupe :: Maybe SourceSpan -> String -> m ()

@@ -147,11 +147,11 @@ resolveImports env (Module ss coms currentModule decls exps) =

147147

148148 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

149149 updateProperRef importModule modExports (ProperRef name) =

150− if name `elem` (fst `map` exportedTypeClasses modExports)

150+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)

151151 then do

152− tell . errorMessage $ DeprecatedClassImport importModule name

153− return $ TypeClassRef name

154− else return $ TypeRef name (Just [])

152+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)

153+ return . TypeClassRef $ ProperName name

154+ else return $ TypeRef (ProperName name) (Just [])

155155 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

156156 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

157157 updateProperRef _ _ other = return other

@@ -226,13 +226,22 @@ resolveImport importModule exps imps impQual = resolveByType

226226 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

227227

228228 -- Check that an explicitly imported item exists in the module it is being imported from

229− checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

229+ checkImportExists

230+ :: Eq a

231+ => (ModuleName -> a -> SimpleErrorMessage)

232+ -> [a]

233+ -> a

234+ -> m ()

230235 checkImportExists unknown exports item =

231236 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

232237

233238 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

234239 -- from

235− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

240+ checkDctorExists

241+ :: ProperName 'TypeName

242+ -> [ProperName 'ConstructorName]

243+ -> ProperName 'ConstructorName

244+ -> m ()

236245 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

237246

238247 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

@@ -268,9 +277,9 @@ resolveImport importModule exps imps impQual = resolveByType

268277 return $ imp { importedValues = values' }

269278 importExplicit imp (TypeRef name dctors) = do

270279 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

271− let exportedDctors :: [(ProperName, ModuleName)]

280+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

272281 exportedDctors = allExportedDataConstructors name

273− dctorNames :: [ProperName]

282+ dctorNames :: [ProperName 'ConstructorName]

274283 dctorNames = fst `map` exportedDctors

275284 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

276285 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

@@ -282,7 +291,7 @@ resolveImport importModule exps imps impQual = resolveByType

282291 importExplicit _ _ = internalError "Invalid argument to importExplicit"

283292

284293 -- Find all exported data constructors for a given type

285− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

294+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

286295 allExportedDataConstructors name =

287296 case find ((== name) . fst . fst) (exportedTypes exps) of

288297 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/TypeClasses.hs+63−38

@@ -1,22 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.TypeClasses

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

115-- |

126-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

137-- and dictionary expressions for type class instances.

148--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE RecordWildCards #-}

19−

209module Language.PureScript.Sugar.TypeClasses

2110 ( desugarTypeClasses

2211 , typeClassMemberName

@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)

4736

4837import qualified Data.Map as M

4938

50−type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])

39+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])

5140

5241type Desugar = StateT MemberMap

5342

@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap

5544-- Add type synonym declarations for type class dictionary types, and value declarations for type class

5645-- instance dictionary expressions.

5746--

58−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

47+desugarTypeClasses

48+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

49+ => [ExternsFile]

50+ -> [Module]

51+ -> m [Module]

5952desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

6053 where

6154 initialState :: MemberMap

6255 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

6356

64− fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

57+ fromExternsDecl

58+ :: ModuleName

59+ -> ExternsDeclaration

60+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

6561 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

6662 fromExternsDecl _ _ = Nothing

6763

68−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

64+desugarModule

65+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

66+ => Module

67+ -> Desugar m Module

6968desugarModule (Module ss coms name decls (Just exps)) = do

7069 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

7170 return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

@@ -171,7 +170,12 @@ desugarModule _ = internalError "Exports should have been elaborated in name des

171170-- return new Sub(fooString, "");

172171-- };

173172-}

174−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

173+desugarDecl

174+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> [DeclarationRef]

177+ -> Declaration

178+ -> Desugar m (Maybe DeclarationRef, [Declaration])

175179desugarDecl mn exps = go

176180 where

177181 go d@(TypeClassDeclaration name args implies members) = do

@@ -187,48 +191,60 @@ desugarDecl mn exps = go

187191 return (dr, map (PositionedDeclaration pos com) ds)

188192 go other = return (Nothing, [other])

189193

190− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

194+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef

191195 expRef name className tys

192196 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

193197 | otherwise = Nothing

194198

195− isExportedClass :: Qualified ProperName -> Bool

199+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool

196200 isExportedClass = isExported (elem . TypeClassRef)

197201

198− isExportedType :: Qualified ProperName -> Bool

202+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool

199203 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

200204

201− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

205+ isExported

206+ :: (ProperName a -> [DeclarationRef] -> Bool)

207+ -> Qualified (ProperName a)

208+ -> Bool

202209 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203210 isExported _ _ = internalError "Names should have been qualified in name desugaring"

204211

205− matchesTypeRef :: ProperName -> DeclarationRef -> Bool

212+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool

206213 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207214 matchesTypeRef _ _ = False

208215

209− getConstructors :: Type -> [Qualified ProperName]

216+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]

210217 getConstructors = everythingOnTypes (++) getConstructor

211−

212− getConstructor :: Type -> [Qualified ProperName]

213− getConstructor (TypeConstructor tcname) = [tcname]

214− getConstructor _ = []

218+ where

219+ getConstructor (TypeConstructor tcname) = [tcname]

220+ getConstructor _ = []

215221

216222memberToNameAndType :: Declaration -> (Ident, Type)

217223memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218224memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219225memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220226

221−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

227+typeClassDictionaryDeclaration

228+ :: ProperName 'ClassName

229+ -> [(String, Maybe Kind)]

230+ -> [Constraint]

231+ -> [Declaration]

232+ -> Declaration

222233typeClassDictionaryDeclaration name args implies members =

223234 let superclassTypes = superClassDictionaryNames implies `zip`

224− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)

235+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

225236 | (superclass, tyArgs) <- implies

226237 ]

227238 members' = map (first runIdent . memberToNameAndType) members

228239 mtys = members' ++ superclassTypes

229− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

230−

231−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

240+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))

241+

242+typeClassMemberToDictionaryAccessor

243+ :: ModuleName

244+ -> ProperName 'ClassName

245+ -> [(String, Maybe Kind)]

246+ -> Declaration

247+ -> Declaration

232248typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

233249 let className = Qualified (Just mn) name

234250 in ValueDeclaration ident Private [] $ Right $

@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration

241257unit :: Type

242258unit = TypeApp tyObject REmpty

243259

244−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

260+typeInstanceDictionaryDeclaration

261+ :: forall m

262+ . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

263+ => Ident

264+ -> ModuleName

265+ -> [Constraint]

266+ -> Qualified (ProperName 'ClassName)

267+ -> [Type]

268+ -> [Declaration]

269+ -> Desugar m Declaration

245270typeInstanceDictionaryDeclaration name mn deps className tys decls =

246271 rethrow (addHint (ErrorInInstance className tys)) $ do

247272 m <- get

@@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

273298 ]

274299

275300 let props = ObjectLiteral (members ++ superclasses)

276− dictTy = foldl TypeApp (TypeConstructor className) tys

301+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

277302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

278303 dict = TypeClassDictionaryConstructorApp className props

279304 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

287312 declName (TypeDeclaration ident _) = Just ident

288313 declName _ = Nothing

289314

290− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

315+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr

291316 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292317 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293318 return val

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+32−14

@@ -8,9 +8,7 @@

88-- |

99-- This module implements the generic deriving elaboration that takes place during desugaring.

1010--

11−module Language.PureScript.Sugar.TypeClasses.Deriving (

12− deriveInstances

13−) where

11+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

1412

1513import Prelude ()

1614import Prelude.Compat

@@ -32,12 +30,20 @@ import Language.PureScript.Types

3230import qualified Language.PureScript.Constants as C

3331

3432-- | Elaborates deriving instance declarations by code generation.

35−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module

33+deriveInstances

34+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)

35+ => Module

36+ -> m Module

3637deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

3738

3839-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

3940-- elaborates that into an instance declaration via code generation.

40−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

41+deriveInstance

42+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

43+ => ModuleName

44+ -> [Declaration]

45+ -> Declaration

46+ -> m Declaration

4147deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

4248 | className == Qualified (Just dataGeneric) (ProperName C.generic)

4349 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

@@ -48,7 +54,7 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

4854deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

4955deriveInstance _ _ e = return e

5056

51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

57+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

5258unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

5359unwrapTypeConstructor (TypeApp ty arg) = do

5460 (tyCon, args) <- unwrapTypeConstructor ty

@@ -64,7 +70,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

6470typesProxy :: ModuleName

6571typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

6672

67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

73+deriveGeneric

74+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

75+ => ModuleName

76+ -> [Declaration]

77+ -> ProperName 'TypeName

78+ -> [Type]

79+ -> m [Declaration]

6880deriveGeneric mn ds tyConNm args = do

6981 tyCon <- findTypeDecl tyConNm ds

7082 toSpine <- mkSpineFunction mn tyCon

@@ -75,7 +87,11 @@ deriveGeneric mn ds tyConNm args = do

7587 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

7688 ]

7789

78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

90+findTypeDecl

91+ :: (Functor m, MonadError MultipleErrors m)

92+ => ProperName 'TypeName

93+ -> [Declaration]

94+ -> m Declaration

7995findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

8096 where

8197 isTypeDecl :: Declaration -> Bool

@@ -92,7 +108,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

92108 recordConstructor :: Expr -> Expr

93109 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

94110

95− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

111+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

96112 mkCtorClause (ctorName, tys) = do

97113 idents <- replicateM (length tys) freshIdent'

98114 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

@@ -125,10 +141,12 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull

125141 proxy :: Type -> Type

126142 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

127143

128− mkProdClause :: (ProperName, [Type]) -> Expr

129− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

130− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

131− ]

144+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

145+ mkProdClause (ctorName, tys) =

146+ ObjectLiteral

147+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

148+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

149+ ]

132150

133151 mkProductSignature :: Type -> Expr

134152 mkProductSignature r | Just rec <- objectType r =

@@ -158,7 +176,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

158176 recordBinder :: [Binder] -> Binder

159177 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

160178

161− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

179+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

162180 mkAlternative (ctorName, tys) = do

163181 idents <- replicateM (length tys) freshIdent'

164182 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

src/Language/PureScript/TypeChecker.hs+79−77

@@ -39,15 +39,15 @@ import Language.PureScript.TypeClassDictionaries

3939import Language.PureScript.Environment

4040import Language.PureScript.Errors

4141

42−addDataType ::

43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

44− ModuleName ->

45− DataDeclType ->

46− ProperName ->

47− [(String, Maybe Kind)] ->

48− [(ProperName, [Type])] ->

49− Kind ->

50− m ()

42+addDataType

43+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

44+ => ModuleName

45+ -> DataDeclType

46+ -> ProperName 'TypeName

47+ -> [(String, Maybe Kind)]

48+ -> [(ProperName 'ConstructorName, [Type])]

49+ -> Kind

50+ -> m ()

5151addDataType moduleName dtype name args dctors ctorKind = do

5252 env <- getEnv

5353 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

@@ -55,15 +55,15 @@ addDataType moduleName dtype name args dctors ctorKind = do

5555 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $

5656 addDataConstructor moduleName dtype name (map fst args) dctor tys

5757

58−addDataConstructor ::

59− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

60− ModuleName ->

61− DataDeclType ->

62− ProperName ->

63− [String] ->

64− ProperName ->

65− [Type] ->

66− m ()

58+addDataConstructor

59+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60+ => ModuleName

61+ -> DataDeclType

62+ -> ProperName 'TypeName

63+ -> [String]

64+ -> ProperName 'ConstructorName

65+ -> [Type]

66+ -> m ()

6767addDataConstructor moduleName dtype name args dctor tys = do

6868 env <- getEnv

6969 traverse_ checkTypeSynonyms tys

@@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do

7373 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]

7474 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

7575

76−addTypeSynonym ::

77− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

78− ModuleName ->

79− ProperName ->

80− [(String, Maybe Kind)] ->

81− Type ->

82− Kind ->

83− m ()

76+addTypeSynonym

77+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

78+ => ModuleName

79+ -> ProperName 'TypeName

80+ -> [(String, Maybe Kind)]

81+ -> Type

82+ -> Kind

83+ -> m ()

8484addTypeSynonym moduleName name args ty kind = do

8585 env <- getEnv

8686 checkTypeSynonyms ty

8787 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

8888 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

8989

90−valueIsNotDefined ::

91− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

92− ModuleName ->

93− Ident ->

94− m ()

90+valueIsNotDefined

91+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

92+ => ModuleName

93+ -> Ident

94+ -> m ()

9595valueIsNotDefined moduleName name = do

9696 env <- getEnv

9797 case M.lookup (moduleName, name) (names env) of

9898 Just _ -> throwError . errorMessage $ RedefinedIdent name

9999 Nothing -> return ()

100100

101−addValue ::

102− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

103− ModuleName ->

104− Ident ->

105− Type ->

106− NameKind ->

107− m ()

101+addValue

102+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

103+ => ModuleName

104+ -> Ident

105+ -> Type

106+ -> NameKind

107+ -> m ()

108108addValue moduleName name ty nameKind = do

109109 env <- getEnv

110110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

111111

112−addTypeClass ::

113− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

114− ModuleName ->

115− ProperName ->

116− [(String, Maybe Kind)] ->

117− [Constraint] ->

118− [Declaration] ->

119− m ()

112+addTypeClass

113+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

114+ => ModuleName

115+ -> ProperName 'ClassName

116+ -> [(String, Maybe Kind)]

117+ -> [Constraint]

118+ -> [Declaration]

119+ -> m ()

120120addTypeClass moduleName pn args implies ds =

121121 let members = map toPair ds in

122122 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

@@ -125,30 +125,30 @@ addTypeClass moduleName pn args implies ds =

125125 toPair (PositionedDeclaration _ _ d) = toPair d

126126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

127127

128−addTypeClassDictionaries ::

129− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

130− Maybe ModuleName ->

131− M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->

132− m ()

128+addTypeClassDictionaries

129+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

130+ => Maybe ModuleName

131+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

132+ -> m ()

133133addTypeClassDictionaries mn entries =

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

135135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

136136

137−checkDuplicateTypeArguments ::

138− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

139− [String] ->

140− m ()

137+checkDuplicateTypeArguments

138+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

139+ => [String]

140+ -> m ()

141141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

142142 throwError . errorMessage $ DuplicateTypeArgument dup

143143 where

144144 firstDup :: Maybe String

145145 firstDup = listToMaybe $ args \\ nub args

146146

147−checkTypeClassInstance ::

148− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

149− ModuleName ->

150− Type ->

151− m ()

147+checkTypeClassInstance

148+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149+ => ModuleName

150+ -> Type

151+ -> m ()

152152checkTypeClassInstance _ (TypeVar _) = return ()

153153checkTypeClassInstance _ (TypeConstructor ctor) = do

154154 env <- getEnv

@@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

160160-- |

161161-- Check that type synonyms are fully-applied in a type

162162--

163−checkTypeSynonyms ::

164− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

165− Type ->

166− m ()

163+checkTypeSynonyms

164+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165+ => Type

166+ -> m ()

167167checkTypeSynonyms = void . replaceAllTypeSynonyms

168168

169169-- |

@@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

179179--

180180-- * Process module imports

181181--

182−typeCheckAll :: forall m.

183− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

184− ModuleName ->

185− [DeclarationRef] ->

186− [Declaration] ->

187− m [Declaration]

182+typeCheckAll

183+ :: forall m

184+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185+ => ModuleName

186+ -> [DeclarationRef]

187+ -> [Declaration]

188+ -> m [Declaration]

188189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189190 where

190191 go :: Declaration -> m Declaration

@@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

197198 addDataType moduleName dtype name args' dctors ctorKind

198199 return $ DataDeclaration dtype name args dctors

199200 where

200− checkNewtype :: [(ProperName, [Type])] -> m ()

201+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()

201202 checkNewtype [(_, [_])] = return ()

202203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

@@ -308,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

308309 | otherwise = firstDuplicate xs

309310 firstDuplicate _ = Nothing

310311

311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()

312+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

312313 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313314 | moduleName == mn' || any checkType tys' = return ()

314315 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

@@ -335,10 +336,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

335336-- Type check an entire module and ensure all types and classes defined within the module that are

336337-- required by exported members are also exported.

337338--

338−typeCheckModule :: forall m.

339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

340− Module ->

341− m Module

339+typeCheckModule

340+ :: forall m

341+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

342+ => Module

343+ -> m Module

342344typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

343345typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

344346 modify (\s -> s { checkCurrentModule = Just mn })

@@ -403,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

403405 where

404406 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

405407 go _ = []

406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

408+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

407409 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

408410 extractCurrentModuleClass _ = Nothing

409411

src/Language/PureScript/TypeChecker/Entailment.hs+14−27

@@ -1,24 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Entailment

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Type class entailment

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE ScopedTypeVariables #-}

172{-# LANGUAGE FlexibleContexts #-}

183

19−module Language.PureScript.TypeChecker.Entailment (

20− entails

21−) where

4+-- |

5+-- Type class entailment

6+--

7+module Language.PureScript.TypeChecker.Entailment (entails) where

228

239import Prelude ()

2410import Prelude.Compat

@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C

4632-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

4733-- return a type class dictionary reference.

4834--

49−entails :: forall m.

50− (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

51− ModuleName ->

52− M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->

53− Constraint ->

54− m Expr

35+entails

36+ :: forall m

37+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

38+ => ModuleName

39+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

40+ -> Constraint

41+ -> m Expr

5542entails moduleName context = solve

5643 where

57− forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

44+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

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

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

6047

@@ -64,7 +51,7 @@ entails moduleName context = solve

6451 ctorModules (TypeApp ty _) = ctorModules ty

6552 ctorModules _ = Nothing

6653

67− findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

54+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

6855 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

6956

7057 solve :: Constraint -> m Expr

@@ -72,7 +59,7 @@ entails moduleName context = solve

7259 dict <- go 0 className tys

7360 return $ dictionaryValueToValue dict

7461 where

75− go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue

62+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue

7663 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

7764 go work className' tys' = do

7865 let instances = do

src/Language/PureScript/TypeChecker/Kinds.hs+64−51

@@ -1,18 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Kinds

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the kind checker

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE MultiParamTypeClasses #-}

172{-# LANGUAGE FlexibleInstances #-}

183{-# LANGUAGE FlexibleContexts #-}

@@ -20,12 +5,15 @@

205{-# LANGUAGE ScopedTypeVariables #-}

216{-# LANGUAGE RankNTypes #-}

227

23−module Language.PureScript.TypeChecker.Kinds (

24− kindOf,

25− kindOfWithScopedVars,

26− kindsOf,

27− kindsOfAll

28−) where

8+-- |

9+-- This module implements the kind checker

10+--

11+module Language.PureScript.TypeChecker.Kinds

12+ ( kindOf

13+ , kindOfWithScopedVars

14+ , kindsOf

15+ , kindsOfAll

16+ ) where

2917

3018import Prelude ()

3119import Prelude.Compat

@@ -54,7 +42,11 @@ freshKind = do

5442 return $ KUnknown k

5543

5644-- | Update the substitution to solve a kind constraint

57−solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()

45+solveKind

46+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

47+ => Int

48+ -> Kind

49+ -> m ()

5850solveKind u k = do

5951 occursCheck u k

6052 modify $ \cs -> cs { checkSubstitution =

@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go

7567 go other = other

7668

7769-- | Make sure that an unknown does not occur in a kind

78−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()

70+occursCheck

71+ :: (Functor m, Applicative m, MonadError MultipleErrors m)

72+ => Int

73+ -> Kind

74+ -> m ()

7975occursCheck _ KUnknown{} = return ()

8076occursCheck u k = void $ everywhereOnKindsM go k

8177 where

@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k

8379 go other = return other

8480

8581-- | Unify two kinds

86−unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()

82+unifyKinds

83+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

84+ => Kind

85+ -> Kind

86+ -> m ()

8787unifyKinds k1 k2 = do

8888 sub <- gets checkSubstitution

8989 go (substituteKind sub k1) (substituteKind sub k2)

@@ -100,10 +100,10 @@ unifyKinds k1 k2 = do

100100 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'

101101

102102-- | Infer the kind of a single type

103−kindOf ::

104− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

105− Type ->

106− m Kind

103+kindOf

104+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

105+ => Type

106+ -> m Kind

107107kindOf ty = fst <$> kindOfWithScopedVars ty

108108

109109-- | Infer the kind of a single type, returning the kinds of any scoped type variables

@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =

120120 )

121121

122122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

123−kindsOf ::

124− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

125− Bool ->

126− ModuleName ->

127− ProperName ->

128− [(String, Maybe Kind)] ->

129− [Type] ->

130− m Kind

123+kindsOf

124+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

125+ => Bool

126+ -> ModuleName

127+ -> ProperName 'TypeName

128+ -> [(String, Maybe Kind)]

129+ -> [Type]

130+ -> m Kind

131131kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

132132 tyCon <- freshKind

133133 kargs <- replicateM (length args) freshKind

@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

138138 where

139139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k

140140

141−freshKindVar ::

142− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>

143− (String, Maybe Kind) ->

144− Kind ->

145− m (ProperName, Kind)

141+freshKindVar

142+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

143+ => (String, Maybe Kind)

144+ -> Kind

145+ -> m (ProperName 'TypeName, Kind)

146146freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

147147freshKindVar (arg, Just kind') kind = do

148148 unifyKinds kind kind'

149149 return (ProperName arg, kind')

150150

151151-- | Simultaneously infer the kinds of several mutually recursive type constructors

152−kindsOfAll ::

153− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

154− ModuleName ->

155− [(ProperName, [(String, Maybe Kind)], Type)] ->

156− [(ProperName, [(String, Maybe Kind)], [Type])] ->

157− m ([Kind], [Kind])

152+kindsOfAll

153+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

154+ => ModuleName

155+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

156+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

157+ -> m ([Kind], [Kind])

158158kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

159159 synVars <- replicateM (length syns) freshKind

160160 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

177177 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)

178178

179179-- | Solve the set of kind constraints associated with the data constructors for a type constructor

180−solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind

180+solveTypes

181+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

182+ => Bool

183+ -> [Type]

184+ -> [Kind]

185+ -> Kind

186+ -> m Kind

181187solveTypes isData ts kargs tyCon = do

182188 ks <- traverse (fmap fst . infer) ts

183189 when isData $ do

@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

195201starIfUnknown k = k

196202

197203-- | Infer a kind for a type

198−infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

204+infer

205+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

206+ => Type

207+ -> m (Kind, [(String, Kind)])

199208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

200209

201−infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

210+infer'

211+ :: forall m

212+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

213+ => Type

214+ -> m (Kind, [(String, Kind)])

202215infer' (ForAll ident ty _) = do

203216 k1 <- freshKind

204217 Just moduleName <- checkCurrentModule <$> get

@@ -250,7 +263,7 @@ infer' other = (, []) <$> go other

250263 return $ Row k1

251264 go (ConstrainedType deps ty) = do

252265 forM_ deps $ \(className, tys) -> do

253− k <- go $ foldl TypeApp (TypeConstructor className) tys

266+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

254267 unifyKinds k Star

255268 k <- go ty

256269 unifyKinds k Star

src/Language/PureScript/TypeChecker/Monad.hs+63−32

@@ -1,18 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Monad

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Monads for type checking and type inference and associated data types

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE GeneralizedNewtypeDeriving #-}

172{-# LANGUAGE FlexibleInstances #-}

183{-# LANGUAGE RankNTypes #-}

@@ -20,6 +5,9 @@

205{-# LANGUAGE FlexibleContexts #-}

216{-# LANGUAGE GADTs #-}

227

8+-- |

9+-- Monads for type checking and type inference and associated data types

10+--

2311module Language.PureScript.TypeChecker.Monad where

2412

2513import Prelude ()

@@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

6957type Unknown = Int

7058

7159-- | Temporarily bind a collection of names to values

72−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a

60+bindNames

61+ :: MonadState CheckState m

62+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

63+ -> m a

64+ -> m a

7365bindNames newNames action = do

7466 orig <- get

7567 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -78,7 +70,11 @@ bindNames newNames action = do

7870 return a

7971

8072-- | Temporarily bind a collection of names to types

81−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a

73+bindTypes

74+ :: MonadState CheckState m

75+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

76+ -> m a

77+ -> m a

8278bindTypes newNames action = do

8379 orig <- get

8480 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -87,7 +83,12 @@ bindTypes newNames action = do

8783 return a

8884

8985-- | Temporarily bind a collection of names to types

90−withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a

86+withScopedTypeVars

87+ :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)

88+ => ModuleName

89+ -> [(String, Kind)]

90+ -> m a

91+ -> m a

9192withScopedTypeVars mn ks ma = do

9293 orig <- get

9394 forM_ ks $ \(name, _) ->

@@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do

9697 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

9798

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

99−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

100+withTypeClassDictionaries

101+ :: MonadState CheckState m

102+ => [TypeClassDictionaryInScope]

103+ -> m a

104+ -> m a

100105withTypeClassDictionaries entries action = do

101106 orig <- get

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

@@ -106,25 +111,35 @@ withTypeClassDictionaries entries action = do

106111 return a

107112

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

109−getTypeClassDictionaries ::

110− (Functor m, MonadState CheckState m) =>

111− m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

114+getTypeClassDictionaries

115+ :: (Functor m, MonadState CheckState m)

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

112117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

113118

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

115−lookupTypeClassDictionaries ::

116− (Functor m, MonadState CheckState m) =>

117− Maybe ModuleName ->

118− m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

120+lookupTypeClassDictionaries

121+ :: (Functor m, MonadState CheckState m)

122+ => Maybe ModuleName

123+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

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

120125

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

122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

127+bindLocalVariables

128+ :: (Functor m, MonadState CheckState m)

129+ => ModuleName

130+ -> [(Ident, Type, NameVisibility)]

131+ -> m a

132+ -> m a

123133bindLocalVariables moduleName bindings =

124134 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

125135

126136-- | Temporarily bind a collection of names to local type variables

127−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

137+bindLocalTypeVariables

138+ :: (Functor m, MonadState CheckState m)

139+ => ModuleName

140+ -> [(ProperName 'TypeName, Kind)]

141+ -> m a

142+ -> m a

128143bindLocalTypeVariables moduleName bindings =

129144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

130145

@@ -145,7 +160,11 @@ preservingNames action = do

145160 return a

146161

147162-- | Lookup the type of a value by name in the @Environment@

148−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

163+lookupVariable

164+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

165+ => ModuleName

166+ -> Qualified Ident

167+ -> m Type

149168lookupVariable currentModule (Qualified moduleName var) = do

150169 env <- getEnv

151170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do

153172 Just (ty, _, _) -> return ty

154173

155174-- | Lookup the visibility of a value by name in the @Environment@

156−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

175+getVisibility

176+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

177+ => ModuleName

178+ -> Qualified Ident

179+ -> m NameVisibility

157180getVisibility currentModule (Qualified moduleName var) = do

158181 env <- getEnv

159182 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do

161184 Just (_, _, vis) -> return vis

162185

163186-- | Assert that a name is visible

164−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

187+checkVisibility

188+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

189+ => ModuleName

190+ -> Qualified Ident

191+ -> m ()

165192checkVisibility currentModule name@(Qualified _ var) = do

166193 vis <- getVisibility currentModule name

167194 case vis of

@@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do

169196 _ -> return ()

170197

171198-- | Lookup the kind of a type by name in the @Environment@

172−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

199+lookupTypeVariable

200+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

201+ => ModuleName

202+ -> Qualified (ProperName 'TypeName)

203+ -> m Kind

173204lookupTypeVariable currentModule (Qualified moduleName name) = do

174205 env <- getEnv

175206 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

src/Language/PureScript/TypeChecker/Types.hs+11−6

@@ -468,11 +468,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

468468-- |

469469-- Check the type of a value

470470--

471−check' :: forall m.

472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

473− Expr ->

474− Type ->

475− m Expr

471+check'

472+ :: forall m

473+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

474+ => Expr

475+ -> Type

476+ -> m Expr

476477check' val (ForAll ident ty _) = do

477478 scope <- newSkolemScope

478479 sko <- newSkolemConstant

@@ -492,7 +493,11 @@ check' val t@(ConstrainedType constraints ty) = do

492493 where

493494 -- | Add a dictionary for the constraint to the scope, and dictionaries

494495 -- for all implied superclass instances.

495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]

496+ newDictionaries

497+ :: [(Qualified (ProperName 'ClassName), Integer)]

498+ -> Qualified Ident

499+ -> (Qualified (ProperName 'ClassName), [Type])

500+ -> m [TypeClassDictionaryInScope]

496501 newDictionaries path name (className, instanceTy) = do

497502 tcs <- gets (typeClasses . checkEnv)

498503 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

src/Language/PureScript/TypeClassDictionaries.hs+3−17

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeClassDictionaries

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162

173module Language.PureScript.TypeClassDictionaries where

@@ -29,9 +15,9 @@ data TypeClassDictionaryInScope

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

3016 tcdName :: Qualified Ident

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

32− , tcdPath :: [(Qualified ProperName, Integer)]

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

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

34− , tcdClassName :: Qualified ProperName

20+ , tcdClassName :: Qualified (ProperName 'ClassName)

3521 -- | The types to which this type class instance applies

3622 , tcdInstanceTypes :: [Type]

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

@@ -58,5 +44,5 @@ data DictionaryValue

5844 -- |

5945 -- A subclass dictionary

6046 --

61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

47+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer

6248 deriving (Show, Read, Ord, Eq)

src/Language/PureScript/Types.hs+5−17

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Data types for types

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE DeriveDataTypeable #-}

172{-# LANGUAGE GeneralizedNewtypeDeriving #-}

183{-# LANGUAGE TemplateHaskell #-}

194

5+-- |

6+-- Data types for types

7+--

208module Language.PureScript.Types where

219

2210import Prelude ()

@@ -60,7 +48,7 @@ data Type

6048 -- |

6149 -- A type constructor

6250 --

63− | TypeConstructor (Qualified ProperName)

51+ | TypeConstructor (Qualified (ProperName 'TypeName))

6452 -- |

6553 -- A type application

6654 --

@@ -106,7 +94,7 @@ data Type

10694-- |

10795-- A typeclass constraint

10896--

109−type Constraint = (Qualified ProperName, [Type])

97+type Constraint = (Qualified (ProperName 'ClassName), [Type])

11098

11199$(A.deriveJSON A.defaultOptions ''Type)

112100