8ca3d1e · rowtype-yoga/purescript-native

hierarchy/Main.hs+2−1

compare with golang

unifiedsplit

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

14-----------------------------------------------------------------------------

15

16{-# LANGUAGE TupleSections #-}

17+{-# LANGUAGE DataKinds #-}

17

18

18module Main where

19module Main where

19

20

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

38 , hierarchyOutput :: Maybe FilePath

39 , hierarchyOutput :: Maybe FilePath

39 }

40 }

40

41

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

42 deriving Eq

43 deriving Eq

43

44

44instance Show SuperMap where

45instance Show SuperMap where

psci/Completion.hs+6−4

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

1+{-# LANGUAGE DataKinds #-}

2+

1module Completion where

3module Completion where

2

4

3import Prelude ()

5import Prelude ()

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

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

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

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

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

186

188

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

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

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

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

189 where

191 where

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

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

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

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

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

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

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

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

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

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

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

205 getDeclNames _ = []

207 getDeclNames _ = []

206

208

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

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

208dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

210dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

209 where

211 where

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

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

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

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

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

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

213 go _ = []

215 go _ = []

psci/PSCi.hs+20−10

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

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TupleSections #-}

5+{-# LANGUAGE DataKinds #-}

5

6

6-- |

7-- |

7-- PureScript Compiler Interactive.

8-- PureScript Compiler Interactive.

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

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

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

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

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

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

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

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

330+ showRef (P.ProperRef pn) = pn

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

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

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

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

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

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

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

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

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

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

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

393

394

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)

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

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

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

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

396

400

401+ showTypeClass

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

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

403+ -> Maybe Box.Box

398 showTypeClass (_, Nothing) = Nothing

404 showTypeClass (_, Nothing) = Nothing

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

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

400 let constraints =

406 let constraints =

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

418 Box.// Box.moveRight 2 classBody

424 Box.// Box.moveRight 2 classBody

419

425

420

426

427+ findType

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

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

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

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

423

432

433+ showType

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

434+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(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])

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

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

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

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

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

428− -> Maybe Box.Box

438+ -> Maybe Box.Box

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

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

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

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

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

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

432− if M.member n typeClassesEnv

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

433 then

443 then

434 Nothing

444 Nothing

435 else

445 else

purescript.cabal+2

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

178 Control.Monad.Supply.Class

179

180 System.IO.UTF8

181+

182+ extensions: DataKinds

181 exposed: True

183 exposed: True

182 buildable: True

184 buildable: True

183 hs-source-dirs: src

185 hs-source-dirs: src

src/Language/PureScript.hs−1

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

13--

14-----------------------------------------------------------------------------

15

16−{-# LANGUAGE DataKinds #-}

17{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE FlexibleContexts #-}

18{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

19

18

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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16

2

3+-- |

4+-- Case binders

5+--

17module Language.PureScript.AST.Binders where

6module Language.PureScript.AST.Binders where

18

7

19import qualified Data.Data as D

8import qualified Data.Data as D

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

54 -- |

43 -- |

55 -- A binder which matches a data constructor

44 -- A binder which matches a data constructor

56 --

45 --

57− | ConstructorBinder (Qualified ProperName) [Binder]

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

58 -- |

47 -- |

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

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

60 --

49 --

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

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

60 -- |

61 -- A type constructor with data constructors

62 --

63− = TypeRef ProperName (Maybe [ProperName])

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

64 -- |

65 -- A value

66 --

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

68 -- |

69 -- A type class

70 --

71− | TypeClassRef ProperName

71+ | TypeClassRef (ProperName 'ClassName)

72 -- |

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

74 --

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

80 -- |

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

82 -- or TypeRef during name desugaring.

83− | ProperRef ProperName

83+ | ProperRef String

84 -- |

85 -- A declaration reference with source position information

86 --

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

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

109-- list of duplicate data constructors.

110--

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

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

112findDuplicateRefs refs =

113 let positionless = stripPosInfo `map` refs

114 simplified = simplifyTypeRefs `map` positionless

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

154 -- |

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

156 --

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

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

158 -- |

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

160 --

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

162 -- |

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

164 --

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

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

166 -- |

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

168 --

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

182 -- |

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

184 --

185− | ExternDataDeclaration ProperName Kind

185+ | ExternDataDeclaration (ProperName 'TypeName) Kind

186 -- |

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

188 --

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

195 -- |

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

197 --

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

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

199 -- |

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

201 -- declarations)

202 --

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

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

204 -- |

205 -- A declaration with source position information

206 --

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

390 -- |

391 -- A data constructor

392 --

393− | Constructor (Qualified ProperName)

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

394 -- |

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

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

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

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

413 -- an ObjectLiteral.

414 --

415− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

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

416 -- |

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

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

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

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

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

422 --

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

424 -- |

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

426 --

427− | TypeClassDictionaryAccessor (Qualified ProperName) Ident

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

428 -- |

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

430 --

431− | SuperClassDictionary (Qualified ProperName) [Type]

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

432 -- |

433 -- A value with source position information

434 --

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

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

1−

2−module Language.PureScript.AST.Exported (

1+module Language.PureScript.AST.Exported

3− exportedDeclarations,

2+ ( exportedDeclarations

4− isExported

3+ , isExported

5−) where

4+ ) where

6

5

7import Control.Category ((>>>))

6import Control.Category ((>>>))

8import Data.Maybe (mapMaybe)

7import Data.Maybe (mapMaybe)

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

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

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

24--

23--

25exportedDeclarations :: Module -> [Declaration]

24exportedDeclarations :: Module -> [Declaration]

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

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

27 where

26 where

28 go = flattenDecls

27 go = flattenDecls

29 >>> filter (isExported exps)

28 >>> filter (isExported exps)

30 >>> map (filterDataConstructors exps)

29 >>> map (filterDataConstructors exps)

31− >>> filterInstances exps

30+ >>> filterInstances mn exps

32

31

33-- |

32-- |

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

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

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

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

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

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

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

54--

53--

54+filterInstances

55+ :: ModuleName

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

56+ -> Maybe [DeclarationRef]

57+ -> [Declaration]

58+ -> [Declaration]

56−filterInstances Nothing = id

59+filterInstances _ Nothing = id

57−filterInstances (Just exps) =

60+filterInstances mn (Just exps) =

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

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

62+ ++ Right `map` mapMaybe typeName exps

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

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

60 where

64 where

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

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

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

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

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

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

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

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

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

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

72+ visibleOutside

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

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

70−

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)

71 typeName (TypeRef n _) = Just n

85 typeName (TypeRef n _) = Just n

72 typeName (PositionedDeclarationRef _ _ r) = typeName r

86 typeName (PositionedDeclarationRef _ _ r) = typeName r

73 typeName _ = Nothing

87 typeName _ = Nothing

74

88

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

75 typeClassName (TypeClassRef n) = Just n

90 typeClassName (TypeClassRef n) = Just n

76 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

91 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

77 typeClassName _ = Nothing

92 typeClassName _ = Nothing

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

79-- |

94-- |

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

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

81--

96--

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

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

83typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

98typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

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

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

85 where

100 where

86

101

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

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

88 fromType = everythingOnTypes (++) go

103 fromType = everythingOnTypes (++) go

89

104

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

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

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

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

92− go (TypeConstructor n) = [n]

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

93 go (ConstrainedType cs _) = concatMap fromConstraint cs

108 go (ConstrainedType cs _) = concatMap fromConstraint cs

94 go _ = []

109 go _ = []

95

110

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

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

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

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

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

120

135

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

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

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

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

123

138

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

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

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

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

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

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

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

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

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

131--

146--

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

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

133isDctorExported _ Nothing _ = True

148isDctorExported _ Nothing _ = True

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

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

135 where

150 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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

17

3

4+-- |

5+-- The core functional representation for binders

6+--

18module Language.PureScript.CoreFn.Binders where

7module Language.PureScript.CoreFn.Binders where

19

8

20import qualified Data.Data as D

9import qualified Data.Data as D

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

39 --

28 --

40 | VarBinder a Ident

29 | VarBinder a Ident

41 -- |

30 -- |

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

31+ -- A binder which matches a data constructor

43 --

32 --

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

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

45 -- |

34 -- |

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

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

47 --

36 --

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

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

170 -- |

171 -- Gets metadata for data constructors.

172 --

173− getConstructorMeta :: Qualified ProperName -> Meta

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

174 getConstructorMeta ctor =

175 case lookupConstructor env ctor of

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

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

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

179 in IsConstructor constructorType fields

180 where

181+

182+ numConstructors

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

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

184+ -> Int

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

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

186+

187+ typeConstructor

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

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

189+ -> (ModuleName, ProperName 'TypeName)

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

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

185 typeConstructor _ = internalError "Invalid argument to typeConstructor"

191 typeConstructor _ = internalError "Invalid argument to typeConstructor"

186

192

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

255-- |

261-- |

256-- Converts a ProperName to an Ident.

262-- Converts a ProperName to an Ident.

257--

263--

258−properToIdent :: ProperName -> Ident

264+properToIdent :: ProperName a -> Ident

259properToIdent = Ident . runProperName

265properToIdent = 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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

17

3

4+-- |

5+-- The core functional representation

6+--

18module Language.PureScript.CoreFn.Expr where

7module Language.PureScript.CoreFn.Expr where

19

8

20import Control.Arrow ((***))

9import Control.Arrow ((***))

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

36 -- |

25 -- |

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

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

38 --

27 --

39− | Constructor a ProperName ProperName [Ident]

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

40 -- |

29 -- |

41 -- A record property accessor

30 -- A record property accessor

42 --

31 --

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

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

172 extractProperNames _ = []

173

174 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

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

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

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

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

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

97 where

98 renderType' = renderTypeWithOptions opts

99

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

100+renderConstraint :: P.Constraint -> RenderedCode

101renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

102

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

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

104renderConstraintWithOptions 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

106

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

108renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

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

119 mintersperse (syntax "," <> sp)

120 (map (renderConstraintWithOptions opts) constraints)

121

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

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

123notQualified = P.Qualified Nothing . P.ProperName

124

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

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

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

52 ]

53 where

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

55+ renderDep :: Constraint -> RenderedCode

55 renderDep (pn, tys) =

56 renderDep (pn, tys) =

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

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

57− in renderType instApp

58+ in renderType instApp

58 match REmpty =

59 match REmpty =

59 Just (syntax "()")

60 Just (syntax "()")

60 match row@RCons{} =

61 match row@RCons{} =

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

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

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

400 <*> nth 1 (eachInArray asType)

401

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

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

403asQualifiedProperName = fromAesonParser

404

405asQualifiedIdent :: 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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

17{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

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

43 -- |

29 -- |

44 -- Type names currently in scope

30 -- Type names currently in scope

45 --

31 --

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

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

47 -- |

33 -- |

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

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

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

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

51 -- |

37 -- |

52 -- Type synonyms currently in scope

38 -- Type synonyms currently in scope

53 --

39 --

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

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

55 -- |

41 -- |

56 -- Available type class dictionaries

42 -- Available type class dictionaries

57 --

43 --

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

59 -- |

45 -- |

60 -- Type classes

46 -- Type classes

61 --

47 --

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

63 } deriving (Show, Read)

49 } deriving (Show, Read)

64

50

65-- |

51-- |

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

107 -- |

93 -- |

108 -- Data type

94 -- Data type

109 --

95 --

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

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

111 -- |

97 -- |

112 -- Type synonym

98 -- Type synonym

113 --

99 --

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

156-- |

142-- |

157-- Construct a ProperName in the Prim module

143-- Construct a ProperName in the Prim module

158--

144--

159−primName :: String -> Qualified ProperName

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

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

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

161

147

162-- |

148-- |

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

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

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

241-- the class with the same name.

227-- the class with the same name.

242--

228--

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

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

244primTypes =

230primTypes =

245 M.fromList

231 M.fromList

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

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

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

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

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

259-- kind of magic constraint for partial functions.

245-- kind of magic constraint for partial functions.

260--

246--

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

262primClasses =

248primClasses =

263 M.fromList

249 M.fromList

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

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

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

266-- |

252-- |

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

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

268--

254--

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

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

270lookupConstructor env ctor =

256lookupConstructor env ctor =

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

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

272

258

273-- |

259-- |

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

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

275--

261--

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

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

277isNewtypeConstructor e ctor = case lookupConstructor e ctor of

263isNewtypeConstructor e ctor = case lookupConstructor e ctor of

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

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

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

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

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

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

53 | RedefinedIdent Ident

54 | OverlappingNamesInLet

55 | UnknownModule ModuleName

56− | UnknownType (Qualified ProperName)

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

57− | UnknownTypeClass (Qualified ProperName)

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

58 | UnknownValue (Qualified Ident)

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

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

60− | UnknownTypeConstructor (Qualified ProperName)

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

61− | UnknownImportType ModuleName ProperName

61+ | UnknownImportType ModuleName (ProperName 'TypeName)

62− | UnknownExportType ProperName

62+ | UnknownExportType (ProperName 'TypeName)

63− | UnknownImportTypeClass ModuleName ProperName

63+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

64− | UnknownExportTypeClass ProperName

64+ | UnknownExportTypeClass (ProperName 'ClassName)

65 | UnknownImportValue ModuleName Ident

66 | UnknownExportValue Ident

67 | UnknownExportModule ModuleName

68− | UnknownImportDataConstructor ModuleName ProperName ProperName

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

69− | UnknownExportDataConstructor ProperName ProperName

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

70 | ScopeConflict String [ModuleName]

71− | ConflictingTypeDecls ProperName

71+ | ConflictingTypeDecls (ProperName 'TypeName)

72− | ConflictingCtorDecls ProperName

72+ | ConflictingCtorDecls (ProperName 'ConstructorName)

73− | TypeConflictsWithClass ProperName

73+ | TypeConflictsWithClass (ProperName 'TypeName)

74− | CtorConflictsWithClass ProperName

74+ | CtorConflictsWithClass (ProperName 'ConstructorName)

75− | ClassConflictsWithType ProperName

75+ | ClassConflictsWithType (ProperName 'ClassName)

76− | ClassConflictsWithCtor ProperName

76+ | ClassConflictsWithCtor (ProperName 'ClassName)

77 | DuplicateModuleName ModuleName

78− | DuplicateClassExport ProperName

78+ | DuplicateClassExport (ProperName 'ClassName)

79 | DuplicateValueExport Ident

80 | DuplicateTypeArgument String

81 | InvalidDoBind

82 | InvalidDoLet

83 | CycleInDeclaration Ident

84− | CycleInTypeSynonym (Maybe ProperName)

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

85 | CycleInModules [ModuleName]

86 | NameIsUndefined Ident

87− | UndefinedTypeVariable ProperName

87+ | UndefinedTypeVariable (ProperName 'TypeName)

88− | PartiallyAppliedSynonym (Qualified ProperName)

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

89 | EscapedSkolem (Maybe Expr)

90 | TypesDoNotUnify Type Type

91 | KindsDoNotUnify Kind Kind

92 | ConstrainedTypeUnified Type Type

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

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

94− | NoInstanceFound (Qualified ProperName) [Type]

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

95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]

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

96− | CannotDerive (Qualified ProperName) [Type]

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

97− | CannotFindDerivingType ProperName

97+ | CannotFindDerivingType (ProperName 'TypeName)

98 | DuplicateLabel String (Maybe Expr)

99 | DuplicateValueDeclaration Ident

100 | ArgListLengthsDiffer Ident

101 | OverlappingArgNames (Maybe Ident)

102 | MissingClassMember Ident

103− | ExtraneousClassMember Ident (Qualified ProperName)

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

104 | ExpectedType Type Kind

105− | IncorrectConstructorArity (Qualified ProperName)

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

106 | ExprDoesNotHaveType Expr Type

107 | PropertyIsMissing String

108 | AdditionalProperty String

109 | CannotApplyFunction Type Expr

110 | TypeSynonymInstance

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

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

112− | InvalidNewtype ProperName

112+ | InvalidNewtype (ProperName 'TypeName)

113 | InvalidInstanceHead Type

114 | TransitiveExportError DeclarationRef [DeclarationRef]

115 | ShadowedName Ident

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

120 | NotExhaustivePattern [[Binder]] Bool

121 | OverlappingPattern [[Binder]] Bool

122 | IncompleteExhaustivityCheck

123− | ClassOperator ProperName Ident

123+ | ClassOperator (ProperName 'ClassName) Ident

124− | MisleadingEmptyTypeImport ModuleName ProperName

124+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

125 | ImportHidingModule ModuleName

126 | UnusedImport ModuleName

127 | UnusedExplicitImport ModuleName [String]

128− | UnusedDctorImport ProperName

128+ | UnusedDctorImport (ProperName 'TypeName)

129− | UnusedDctorExplicitImport ProperName [ProperName]

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

130 | DeprecatedOperatorDecl String

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132− | DeprecatedClassImport ModuleName ProperName

132+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133− | DeprecatedClassExport ProperName

133+ | DeprecatedClassExport (ProperName 'ClassName)

134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135 | DuplicateSelectiveImport ModuleName

136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

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

139 | IntOutOfRange Integer String Integer Integer

140 | RedundantEmptyHidingImport ModuleName

141 | ImplicitImport ModuleName [DeclarationRef]

142− | ImplicitDctorImport ProperName [ProperName]

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

143 | CaseBinderLengthDiffers Int [Binder]

144 deriving (Show)

145

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

148 = ErrorUnifyingTypes Type Type

149 | ErrorInExpression Expr

150 | ErrorInModule ModuleName

151− | ErrorInInstance (Qualified ProperName) [Type]

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

152 | ErrorInSubsumption Type Type

153 | ErrorCheckingAccessor Expr String

154 | ErrorCheckingType Expr Type

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

156 | ErrorCheckingGuard

157 | ErrorInferringType Expr

158 | ErrorInApplication Expr Type Expr

159− | ErrorInDataConstructor ProperName

159+ | ErrorInDataConstructor (ProperName 'ConstructorName)

160− | ErrorInTypeConstructor ProperName

160+ | ErrorInTypeConstructor (ProperName 'TypeName)

161 | ErrorInBindingGroup [Ident]

162 | ErrorInDataBindingGroup

163− | ErrorInTypeSynonym ProperName

163+ | ErrorInTypeSynonym (ProperName 'TypeName)

164 | ErrorInValueDeclaration Ident

165 | ErrorInTypeDeclaration Ident

166 | ErrorInForeignImport Ident

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

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

1011 prettyPrintRef (ValueRef ident) = showIdent ident

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

1013− prettyPrintRef (ProperRef pn) = runProperName pn

1013+ prettyPrintRef (ProperRef name) = name

1014 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

1016 prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

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

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

80data ExternsDeclaration =

81 -- | A type declaration

82 EDType

83− { edTypeName :: ProperName

83+ { edTypeName :: ProperName 'TypeName

84 , edTypeKind :: Kind

85 , edTypeDeclarationKind :: TypeKind

86 }

87 -- | A type synonym

88 | EDTypeSynonym

89− { edTypeSynonymName :: ProperName

89+ { edTypeSynonymName :: ProperName 'TypeName

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

91 , edTypeSynonymType :: Type

92 }

93 -- | A data construtor

94 | EDDataConstructor

95− { edDataCtorName :: ProperName

95+ { edDataCtorName :: ProperName 'ConstructorName

96 , edDataCtorOrigin :: DataDeclType

97− , edDataCtorTypeCtor :: ProperName

97+ , edDataCtorTypeCtor :: ProperName 'TypeName

98 , edDataCtorType :: Type

99 , edDataCtorFields :: [Ident]

100 }

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

105 }

106 -- | A type class declaration

107 | EDClass

108− { edClassName :: ProperName

108+ { edClassName :: ProperName 'ClassName

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

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

111 , edClassConstraints :: [Constraint]

112 }

113 -- | An instance declaration

114 | EDInstance

115− { edInstanceClassName :: Qualified ProperName

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

116 , edInstanceName :: Ident

117 , edInstanceTypes :: [Type]

118 , edInstanceConstraints :: Maybe [Constraint]

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

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

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

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

182 ]

183 _ -> internalError "toExternsDeclaration: Invalid input"

184 toExternsDeclaration (ValueRef ident)

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

186 = [ EDValue ident ty ]

187 toExternsDeclaration (TypeClassRef className)

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

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

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

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

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

191− = [ EDType className kind TypeSynonym

191+ = [ EDType (coerceProperName className) kind TypeSynonym

192− , EDTypeSynonym className args synTy

192+ , EDTypeSynonym (coerceProperName className) args synTy

193 , EDClass className args members implies

194 ]

195 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−

19{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

20{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

21

3

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

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

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

23

11

24import Prelude ()

12import Prelude ()

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

54-- |

42-- |

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

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

56--

44--

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

45+qualifyName

46+ :: (ProperName a)

47+ -> ModuleName

48+ -> Qualified (ProperName b)

49+ -> Qualified (ProperName a)

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

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

59 where

51 where

60 (mn, _) = qualify defmn qn

52 (mn, _) = qualify defmn qn

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

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

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

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

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

67--

59--

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

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

69getConstructors env defmn n = extractConstructors lnte

61getConstructors env defmn n = extractConstructors lnte

70 where

62 where

71− qpn :: Qualified ProperName

72− qpn = getConsDataName n

73

63

74− getConsDataName :: Qualified ProperName -> Qualified ProperName

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

75− getConsDataName con = qualifyName nm defmn con

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

76− where

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

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

86

67

87 lnte :: Maybe (Kind, TypeKind)

68 lnte :: Maybe (Kind, TypeKind)

88 lnte = M.lookup qpn (types env)

69 lnte = M.lookup qpn (types env)

89

70

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

71+ qpn :: Qualified (ProperName 'TypeName)

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

72+ qpn = getConsDataName n

73+

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

75+ getConsDataName con =

76+ case getConsInfo con of

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

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)

93

82

94-- |

83-- |

95-- Replicates a wildcard binder

84-- Replicates a wildcard binder

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

303 hasPartialConstraint :: Type -> Bool

292 hasPartialConstraint :: Type -> Bool

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

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

305 where

294 where

306− go :: Qualified ProperName -> Bool

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

307 go qname

296 go qname

308 | qname == partialClass = True

297 | qname == partialClass = True

309 | otherwise =

298 | otherwise =

310 case qname `M.lookup` typeClasses env of

299 case qname `M.lookup` typeClasses env of

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

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

312 _ -> False

301 _ -> False

313− partialClass :: Qualified ProperName

302+ partialClass :: Qualified (ProperName 'ClassName)

314 partialClass = primName "Partial"

303 partialClass = primName "Partial"

315 hasPartialConstraint _ = False

304 hasPartialConstraint _ = False

316

305

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

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

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

29data Name

30 = IdentName (Qualified Ident)

31− | TypeName (Qualified ProperName)

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

32− | DctorName (Qualified ProperName)

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

33− | ClassName (Qualified ProperName)

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

34 deriving (Eq)

35

36getIdentName :: Name -> Maybe Ident

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

38getIdentName _ = Nothing

39

40−getTypeName :: Name -> Maybe ProperName

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

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

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

42getTypeName _ = Nothing

43

44−getClassName :: Name -> Maybe ProperName

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

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

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

46getClassName _ = Nothing

47

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

96

97 _ -> return ()

98 where

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

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

100 reconstructTypeRefs mni = foldr accumDctors M.empty

101 where

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

103

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

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

105 findTypeForDctor mn dctor =

106 case mn `M.lookup` env of

107 Just (_, _, exps) ->

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

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

123 qnameUsed Nothing = False

124

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

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

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

127

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

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

129 dctorsForType mn tn =

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

131 where

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

133 getDctors ((_,ctors),_) = ctors

134

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

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

136 typeForDCtor mn pn =

137 getTy <$> find matches (dtys mn)

138 where

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

140 getTy ((ty, _), _) = ty

141

142

143+matchName

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

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

145+ -> Maybe ModuleName

146+ -> Name

147+ -> Maybe String

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

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

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

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

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

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

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

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

148matchName _ _ _ = Nothing

152matchName _ _ _ = Nothing

149

153

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

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

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

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

152matchDctor _ _ = Nothing

156matchDctor _ _ = Nothing

153

157

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

158runDeclRef (TypeClassRef pn) = Just $ runProperName pn

162runDeclRef (TypeClassRef pn) = Just $ runProperName pn

159runDeclRef _ = Nothing

163runDeclRef _ = Nothing

160

164

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

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

162getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

166getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

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

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

164getTypeRef _ = Nothing

168getTypeRef _ = Nothing

src/Language/PureScript/Make.hs−1

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

1−{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE TupleSections #-}

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

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

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE EmptyDataDecls #-}

5+{-# LANGUAGE KindSignatures #-}

5

6

6-- |

7-- |

7-- Data types for names

8-- Data types for names

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

13

14

14import Data.List

15import Data.List

15import Data.Data

16import Data.Data

17+import Data.Aeson

16import Data.Aeson.TH

18import Data.Aeson.TH

17

19

18-- |

20-- |

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

51-- |

53-- |

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

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

53--

55--

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

55

77

56-- |

78-- |

57-- Module names

79-- Module names

58--

80--

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)

60

82

61runModuleName :: ModuleName -> String

83runModuleName :: ModuleName -> String

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

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

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

98-- |

120-- |

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

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

100--

122--

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

101isUnqualified :: Qualified a -> Bool

130isUnqualified :: Qualified a -> Bool

102−isUnqualified (Qualified Nothing _) = True

131+isUnqualified = not . isQualified

103−isUnqualified _ = False

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

104

139

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

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

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

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

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

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

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

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

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

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

1+{-# LANGUAGE FlexibleContexts #-}

2−--

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

11-- |

3-- |

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

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

13--

5--

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

15−

16−{-# LANGUAGE FlexibleContexts #-}

17−

18module Language.PureScript.Parser.Common where

6module Language.PureScript.Parser.Common where

19

7

20import Control.Applicative

8import Control.Applicative

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

27

15

28import qualified Text.Parsec as P

16import qualified Text.Parsec as P

29

17

30−properName :: TokenParser ProperName

18+properName :: TokenParser (ProperName a)

31properName = ProperName <$> uname

19properName = ProperName <$> uname

32

20

33-- |

21-- |

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

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

165 parseProperRef = do

166 name <- properName

167 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

169

170parseTypeClassDeclaration :: TokenParser Declaration

171parseTypeClassDeclaration = 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−--

11-- |

1-- |

12-- Pretty printer for Types

2-- Pretty printer for Types

13--

3--

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

15−

16−module Language.PureScript.Pretty.Types (

4+module Language.PureScript.Pretty.Types

17− typeAsBox,

5+ ( typeAsBox

18− prettyPrintType,

6+ , prettyPrintType

19− typeAtomAsBox,

7+ , typeAtomAsBox

20− prettyPrintTypeAtom,

8+ , prettyPrintTypeAtom

21− prettyPrintRowWith,

9+ , prettyPrintRowWith

22− prettyPrintRow

10+ , prettyPrintRow

23−) where

11+ ) where

24

12

25import Data.Maybe (fromMaybe)

13import Data.Maybe (fromMaybe)

26

14

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

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

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

51 match _ = Nothing

39 match _ = Nothing

52

40

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

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

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

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

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

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

56

44

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

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

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

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

59

47

60-- |

48-- |

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

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

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

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE ScopedTypeVariables #-}

3−-- Module : Language.PureScript.BindingGroups

3+{-# LANGUAGE LambdaCase #-}

4+

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

5-- |

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

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

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

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

14--

8--

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

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20−module Language.PureScript.Sugar.BindingGroups (

9+module Language.PureScript.Sugar.BindingGroups

21− createBindingGroups,

10+ ( createBindingGroups

22− createBindingGroupsModule,

11+ , createBindingGroupsModule

23− collapseBindingGroups,

12+ , collapseBindingGroups

24− collapseBindingGroupsModule

13+ , collapseBindingGroupsModule

25−) where

14+ ) where

26

15

27import Prelude ()

16import Prelude ()

28import Prelude.Compat

17import Prelude.Compat

29

18

30−import Data.Graph

31−import Data.List (nub, intersect)

32−import Data.Maybe (isJust, mapMaybe)

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

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

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

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

35

21

22+import Data.Graph

23+import Data.List (nub, intersect)

24+import Data.Maybe (isJust, mapMaybe)

36import qualified Data.Set as S

25import qualified Data.Set as S

37

26

38−import Language.PureScript.Crash

39import Language.PureScript.AST

27import Language.PureScript.AST

40−import Language.PureScript.Names

28+import Language.PureScript.Crash

41−import Language.PureScript.Types

42import Language.PureScript.Environment

29import Language.PureScript.Environment

43import Language.PureScript.Errors

30import Language.PureScript.Errors

31+import Language.PureScript.Names

32+import Language.PureScript.Types

44

33

45-- |

34-- |

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

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

47--

36--

37+createBindingGroupsModule

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

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

39+ => [Module]

40+ -> m [Module]

41+createBindingGroupsModule =

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

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

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

50

44

51-- |

45-- |

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

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

53--

47--

54collapseBindingGroupsModule :: [Module] -> [Module]

48collapseBindingGroupsModule :: [Module] -> [Module]

49+collapseBindingGroupsModule =

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

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

51+ Module ss coms name (collapseBindingGroups ds) exps

56−

52+

53+createBindingGroups

54+ :: forall m

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

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

56+ => ModuleName

57+ -> [Declaration]

58+ -> m [Declaration]

58createBindingGroups moduleName = mapM f <=< handleDecls

59createBindingGroups moduleName = mapM f <=< handleDecls

59

60

60 where

61 where

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

71 handleDecls ds = do

72 handleDecls ds = do

72 let values = filter isValueDecl ds

73 let values = filter isValueDecl ds

73 dataDecls = filter isDataDecl ds

74 dataDecls = filter isDataDecl ds

74− allProperNames = map getProperName dataDecls

75+ allProperNames = map getTypeName dataDecls

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

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

76 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

77 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

77 let allIdents = map getIdent values

78 let allIdents = map getIdent values

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

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

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

90-- Collapse all binding groups to individual declarations

91-- Collapse all binding groups to individual declarations

91--

92--

92collapseBindingGroups :: [Declaration] -> [Declaration]

93collapseBindingGroups :: [Declaration] -> [Declaration]

94+collapseBindingGroups =

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

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

96+ in map f . concatMap go

94 where

97 where

95 go (DataBindingGroupDeclaration ds) = ds

98 go (DataBindingGroupDeclaration ds) = ds

99+ go (BindingGroupDeclaration ds) =

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

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

101+ go (PositionedDeclaration pos com d) =

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

102+ map (PositionedDeclaration pos com) $ go d

98 go other = [other]

103 go other = [other]

99

104

100collapseBindingGroupsForValue :: Expr -> Expr

105collapseBindingGroupsForValue :: Expr -> Expr

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

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

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

115

120

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

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

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

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

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

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

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

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

119 usedNamesE _ _ = []

126 usedNamesE _ _ = []

120

127

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

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

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

127

134

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

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

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

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

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

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

132 usedNamesE scope _ = (scope, [])

140 usedNamesE scope _ = (scope, [])

133

141

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

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

135−usedProperNames moduleName =

143+usedTypeNames moduleName =

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

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

137 in nub . f

145 in nub . f

138 where

146 where

139− usedNames :: Type -> [ProperName]

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

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

148+ usedNames (ConstrainedType constraints _) =

141− case qual of

149+ flip mapMaybe constraints $ \case

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

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

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

143 _ -> Nothing

152 _ -> Nothing

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

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

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

145 usedNames _ = []

155 usedNames _ = []

146

156

147getIdent :: Declaration -> Ident

157getIdent :: Declaration -> Ident

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

149getIdent (PositionedDeclaration _ _ d) = getIdent d

159getIdent (PositionedDeclaration _ _ d) = getIdent d

150getIdent _ = internalError "Expected ValueDeclaration"

160getIdent _ = internalError "Expected ValueDeclaration"

151

161

152−getProperName :: Declaration -> ProperName

162+getTypeName :: Declaration -> ProperName 'TypeName

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

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

154−getProperName (TypeSynonymDeclaration pn _ _) = pn

164+getTypeName (TypeSynonymDeclaration pn _ _) = pn

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

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

156−getProperName _ = internalError "Expected DataDeclaration"

166+getTypeName _ = internalError "Expected DataDeclaration"

157

167

158-- |

168-- |

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

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

160--

170--

161--

171--

172+toBindingGroup

173+ :: forall m

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

174+ . (Functor m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> SCC Declaration

177+ -> m Declaration

163toBindingGroup _ (AcyclicSCC d) = return d

178toBindingGroup _ (AcyclicSCC d) = return d

164toBindingGroup moduleName (CyclicSCC ds') =

179toBindingGroup moduleName (CyclicSCC ds') =

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

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

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

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

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

189 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

204 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

190

205

206+toDataBindingGroup

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

207+ :: MonadError MultipleErrors m

208+ => SCC Declaration

209+ -> m Declaration

192toDataBindingGroup (AcyclicSCC d) = return d

210toDataBindingGroup (AcyclicSCC d) = return d

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

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

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

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

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

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

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

198 | otherwise = return $ DataBindingGroupDeclaration ds'

216 | otherwise = return $ DataBindingGroupDeclaration ds'

199

217

200−isTypeSynonym :: Declaration -> Maybe ProperName

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

201isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

219isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

202isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

220isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

203isTypeSynonym _ = Nothing

221isTypeSynonym _ = Nothing

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

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

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

57 where

58

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

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

60 exportedTypes = mapMaybe toExportedType efExports

61 where

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

63 where

64− forTyCon :: ExternsDeclaration -> Maybe ProperName

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

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

66 forTyCon _ = Nothing

67 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

68 toExportedType _ = Nothing

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

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

70 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

71 where

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

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

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

121-- qualified names are valid.

122--

123+renameInModule

124+ :: forall m

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

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

126+ => Env

127+ -> Imports

128+ -> Module

129+ -> m Module

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

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

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

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

126 where

132 where

127

133

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

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

129

135

136+ updateDecl

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

138+ -> Declaration

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

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

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

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

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

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

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

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

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

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

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

147 updateDecl s d = return (s, d)

156 updateDecl s d = return (s, d)

148

157

158+ updateValue

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

160+ -> Expr

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

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

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

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

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

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

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

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

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

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

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

168 updateValue s v = return (s, v)

180 updateValue s v = return (s, v)

169

181

182+ updateBinder

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

184+ -> Binder

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

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

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

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

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

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

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

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

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

179 updateBinder s v =

194 updateBinder s v =

180 return (s, v)

195 return (s, v)

181

196

197+ updateCase

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

199+ -> CaseAlternative

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

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

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

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

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

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

185

203

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

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

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

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

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

201

219

220+ updateTypeName

221+ :: Qualified (ProperName 'TypeName)

222+ -> Maybe SourceSpan

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

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

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

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

204

225

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

226+ updateDataConstructorName

227+ :: Qualified (ProperName 'ConstructorName)

228+ -> Maybe SourceSpan

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

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

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

207

231

232+ updateClassName

233+ :: Qualified (ProperName 'ClassName)

234+ -> Maybe SourceSpan

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

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

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

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

210

237

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

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

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

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

213

240

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

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

218

245

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

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

220 -- original definition.

247 -- original definition.

248+ resolveType

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

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

250+ -> ProperName 'TypeName

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

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

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

223

253

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

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

225 -- module of original definition.

255 -- module of original definition.

256+ resolveDctor

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

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

258+ -> ProperName 'ConstructorName

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

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

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

228

261

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

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

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

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

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

280-- desugars into a `TypeClassRef`.

313-- desugars into a `TypeClassRef`.

281--

314--

315+updateExportRefs

316+ :: forall m

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

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

318+ => Module

319+ -> m Module

283updateExportRefs (Module ss coms mn decls exps) =

320updateExportRefs (Module ss coms mn decls exps) =

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

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

285 where

322 where

286

323

287 updateRef :: DeclarationRef -> m DeclarationRef

324 updateRef :: DeclarationRef -> m DeclarationRef

288 updateRef (ProperRef name)

325 updateRef (ProperRef name)

289− | name `elem` classNames = do

326+ | ProperName name `elem` classNames = do

290− tell . errorMessage $ DeprecatedClassExport name

327+ tell . errorMessage . DeprecatedClassExport $ ProperName name

291− return $ TypeClassRef name

328+ return . TypeClassRef $ ProperName name

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

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

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

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

294 -- be picked up elsewhere

331 -- be picked up elsewhere

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

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

296 updateRef (PositionedDeclarationRef pos com ref) =

333 updateRef (PositionedDeclarationRef pos com ref) =

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

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

298 updateRef other = return other

335 updateRef other = return other

299

336

300− classNames :: [ProperName]

337+ classNames :: [ProperName 'ClassName]

301 classNames = mapMaybe go decls

338 classNames = mapMaybe go decls

302 where

339 where

303 go (PositionedDeclaration _ _ d) = go d

340 go (PositionedDeclaration _ _ d) = go d

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

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

41 -- |

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

43 --

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

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

45 -- |

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

47 --

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

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

49 -- |

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

51 --

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

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

53 -- |

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

55 --

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

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

81 -- came from.

82 --

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

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

84 -- |

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

86 -- came from.

87 --

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

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

89 -- |

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

91 -- came from.

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

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

144-- error if a conflict occurs.

145--

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

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

147exportType exps name dctors mn = do

148 let exTypes' = exportedTypes exps

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

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

151 let exClasses = exportedTypeClasses exps

152−

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

152 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

155 forM_ dctors $ \dctor -> do

154 forM_ dctors $ \dctor -> do

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

155 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

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

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

159

158

160-- |

159-- |

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

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

162--

161--

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

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

164exportTypeClass exps name mn = do

163exportTypeClass exps name mn = do

165 let exTypes = exportedTypes exps

164 let exTypes = exportedTypes exps

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

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

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

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

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

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

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

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

170 return $ exps { exportedTypeClasses = classes }

169 return $ exps { exportedTypeClasses = classes }

171

170

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

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

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

76 _ -> return ()

77

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

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

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

80

81 warnDupe :: String -> m ()

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

151

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

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

154+ resolveTypeExports

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

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

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

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

155 resolveTypeExports tctors dctors = map go tctors

158 resolveTypeExports tctors dctors = map go tctors

156 where

159 where

160+ go

161+ :: Qualified (ProperName 'TypeName)

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

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

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

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

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

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

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

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

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

165

170

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

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

167 -- came from.

172 -- came from.

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

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

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

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

170 resolve exportedTypeClasses className

175 resolve exportedTypeClasses className

171

176

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

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

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

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

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

194--

199--

200+filterModule

201+ :: forall m

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

202+ . (Applicative m, MonadError MultipleErrors m)

203+ => ModuleName

204+ -> Exports

205+ -> [DeclarationRef]

206+ -> m Exports

196filterModule mn exps refs = do

207filterModule mn exps refs = do

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

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

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

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

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

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

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

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

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

208 -- result.

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

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

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

211 rethrowWithPosition pos $ filterTypes exps' result r

226 rethrowWithPosition pos $ filterTypes exps' result r

212 filterTypes exps' result (TypeRef name expDcons) =

227 filterTypes exps' result (TypeRef name expDcons) =

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

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

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

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

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

223 -- the data constructor to check.

238 -- the data constructor to check.

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

239+ checkDcon

240+ :: ProperName 'TypeName

241+ -> [ProperName 'ConstructorName]

242+ -> ProperName 'ConstructorName

243+ -> m ()

225 checkDcon tcon exps' name =

244 checkDcon tcon exps' name =

226 unless (name `elem` exps') $

245 unless (name `elem` exps') $

227 throwError . errorMessage $ UnknownExportDataConstructor tcon name

246 throwError . errorMessage $ UnknownExportDataConstructor tcon name

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

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

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

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

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

232 -- included in the result.

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

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

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

235 rethrowWithPosition pos $ filterClasses exps' result r

258 rethrowWithPosition pos $ filterClasses exps' result r

236 filterClasses exps' result (TypeClassRef name) =

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

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

125 _ -> return ()

126

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

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

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

129

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

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

147

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

149 updateProperRef importModule modExports (ProperRef name) =

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

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

151 then do

152− tell . errorMessage $ DeprecatedClassImport importModule name

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

153− return $ TypeClassRef name

153+ return . TypeClassRef $ ProperName name

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

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

155 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

156 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

157 updateProperRef _ _ other = return other

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

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

227

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

229+ checkImportExists

230+ :: Eq a

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

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

232+ -> [a]

233+ -> a

234+ -> m ()

230 checkImportExists unknown exports item =

235 checkImportExists unknown exports item =

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

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

232

237

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

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

234 -- from

239 -- from

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

240+ checkDctorExists

241+ :: ProperName 'TypeName

242+ -> [ProperName 'ConstructorName]

243+ -> ProperName 'ConstructorName

244+ -> m ()

236 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

245 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

237

246

238 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

247 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

@@ -268,9 +277,9 @@ resolveImport importModule exps imps impQual = resolveByType

268 return $ imp { importedValues = values' }

277 return $ imp { importedValues = values' }

269 importExplicit imp (TypeRef name dctors) = do

278 importExplicit imp (TypeRef name dctors) = do

270 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

279 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

271− let exportedDctors :: [(ProperName, ModuleName)]

280+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

272 exportedDctors = allExportedDataConstructors name

281 exportedDctors = allExportedDataConstructors name

273− dctorNames :: [ProperName]

282+ dctorNames :: [ProperName 'ConstructorName]

274 dctorNames = fst `map` exportedDctors

283 dctorNames = fst `map` exportedDctors

275 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

284 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

276 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

285 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

@@ -282,7 +291,7 @@ resolveImport importModule exps imps impQual = resolveByType

282 importExplicit _ _ = internalError "Invalid argument to importExplicit"

291 importExplicit _ _ = internalError "Invalid argument to importExplicit"

283

292

284 -- Find all exported data constructors for a given type

293 -- Find all exported data constructors for a given type

285− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

294+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

286 allExportedDataConstructors name =

295 allExportedDataConstructors name =

287 case find ((== name) . fst . fst) (exportedTypes exps) of

296 case find ((== name) . fst . fst) (exportedTypes exps) of

288 Nothing -> internalError "Invalid state in allExportedDataConstructors"

297 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/TypeClasses.hs+63−38

@@ -1,22 +1,11 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE RecordWildCards #-}

3−-- Module : Language.PureScript.Sugar.TypeClasses

3+{-# LANGUAGE ScopedTypeVariables #-}

4+

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

5-- |

12-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

6-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

13-- and dictionary expressions for type class instances.

7-- and dictionary expressions for type class instances.

14--

8--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE RecordWildCards #-}

19−

20module Language.PureScript.Sugar.TypeClasses

9module Language.PureScript.Sugar.TypeClasses

21 ( desugarTypeClasses

10 ( desugarTypeClasses

22 , typeClassMemberName

11 , typeClassMemberName

@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)

47

36

48import qualified Data.Map as M

37import qualified Data.Map as M

49

38

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])

51

40

52type Desugar = StateT MemberMap

41type Desugar = StateT MemberMap

53

42

@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap

55-- Add type synonym declarations for type class dictionary types, and value declarations for type class

44-- Add type synonym declarations for type class dictionary types, and value declarations for type class

56-- instance dictionary expressions.

45-- instance dictionary expressions.

57--

46--

47+desugarTypeClasses

58−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

48+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

49+ => [ExternsFile]

50+ -> [Module]

51+ -> m [Module]

59desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

52desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

60 where

53 where

61 initialState :: MemberMap

54 initialState :: MemberMap

62 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

55 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

63

56

57+ fromExternsDecl

58+ :: ModuleName

59+ -> ExternsDeclaration

64− fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

60+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

65 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

61 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

66 fromExternsDecl _ _ = Nothing

62 fromExternsDecl _ _ = Nothing

67

63

64+desugarModule

68−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

65+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

66+ => Module

67+ -> Desugar m Module

69desugarModule (Module ss coms name decls (Just exps)) = do

68desugarModule (Module ss coms name decls (Just exps)) = do

70 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

69 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

71 return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

70 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

171-- return new Sub(fooString, "");

170-- return new Sub(fooString, "");

172-- };

171-- };

173-}

172-}

173+desugarDecl

174−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

174+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> [DeclarationRef]

177+ -> Declaration

178+ -> Desugar m (Maybe DeclarationRef, [Declaration])

175desugarDecl mn exps = go

179desugarDecl mn exps = go

176 where

180 where

177 go d@(TypeClassDeclaration name args implies members) = do

181 go d@(TypeClassDeclaration name args implies members) = do

@@ -187,48 +191,60 @@ desugarDecl mn exps = go

187 return (dr, map (PositionedDeclaration pos com) ds)

191 return (dr, map (PositionedDeclaration pos com) ds)

188 go other = return (Nothing, [other])

192 go other = return (Nothing, [other])

189

193

190− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

194+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef

191 expRef name className tys

195 expRef name className tys

192 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

196 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

193 | otherwise = Nothing

197 | otherwise = Nothing

194

198

195− isExportedClass :: Qualified ProperName -> Bool

199+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool

196 isExportedClass = isExported (elem . TypeClassRef)

200 isExportedClass = isExported (elem . TypeClassRef)

197

201

198− isExportedType :: Qualified ProperName -> Bool

202+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool

199 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

203 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

200

204

205+ isExported

201− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

206+ :: (ProperName a -> [DeclarationRef] -> Bool)

207+ -> Qualified (ProperName a)

208+ -> Bool

202 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

209 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203 isExported _ _ = internalError "Names should have been qualified in name desugaring"

210 isExported _ _ = internalError "Names should have been qualified in name desugaring"

204

211

205− matchesTypeRef :: ProperName -> DeclarationRef -> Bool

212+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool

206 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

213 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207 matchesTypeRef _ _ = False

214 matchesTypeRef _ _ = False

208

215

209− getConstructors :: Type -> [Qualified ProperName]

216+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]

210 getConstructors = everythingOnTypes (++) getConstructor

217 getConstructors = everythingOnTypes (++) getConstructor

211−

218+ where

212− getConstructor :: Type -> [Qualified ProperName]

213− getConstructor (TypeConstructor tcname) = [tcname]

219+ getConstructor (TypeConstructor tcname) = [tcname]

214− getConstructor _ = []

220+ getConstructor _ = []

215

221

216memberToNameAndType :: Declaration -> (Ident, Type)

222memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

223memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

224memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219memberToNameAndType _ = internalError "Invalid declaration in type class definition"

225memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220

226

221−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

227+typeClassDictionaryDeclaration

228+ :: ProperName 'ClassName

229+ -> [(String, Maybe Kind)]

230+ -> [Constraint]

231+ -> [Declaration]

232+ -> Declaration

222typeClassDictionaryDeclaration name args implies members =

233typeClassDictionaryDeclaration name args implies members =

223 let superclassTypes = superClassDictionaryNames implies `zip`

234 let superclassTypes = superClassDictionaryNames implies `zip`

224− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)

235+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

225 | (superclass, tyArgs) <- implies

236 | (superclass, tyArgs) <- implies

226 ]

237 ]

227 members' = map (first runIdent . memberToNameAndType) members

238 members' = map (first runIdent . memberToNameAndType) members

228 mtys = members' ++ superclassTypes

239 mtys = members' ++ superclassTypes

229− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

240+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))

230−

241+

231−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

242+typeClassMemberToDictionaryAccessor

243+ :: ModuleName

244+ -> ProperName 'ClassName

245+ -> [(String, Maybe Kind)]

246+ -> Declaration

247+ -> Declaration

232typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

248typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

233 let className = Qualified (Just mn) name

249 let className = Qualified (Just mn) name

234 in ValueDeclaration ident Private [] $ Right $

250 in ValueDeclaration ident Private [] $ Right $

@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration

241unit :: Type

257unit :: Type

242unit = TypeApp tyObject REmpty

258unit = TypeApp tyObject REmpty

243

259

260+typeInstanceDictionaryDeclaration

261+ :: forall m

244−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

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

245typeInstanceDictionaryDeclaration name mn deps className tys decls =

270typeInstanceDictionaryDeclaration name mn deps className tys decls =

246 rethrow (addHint (ErrorInInstance className tys)) $ do

271 rethrow (addHint (ErrorInInstance className tys)) $ do

247 m <- get

272 m <- get

@@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

273 ]

298 ]

274

299

275 let props = ObjectLiteral (members ++ superclasses)

300 let props = ObjectLiteral (members ++ superclasses)

276− dictTy = foldl TypeApp (TypeConstructor className) tys

301+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

277 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

278 dict = TypeClassDictionaryConstructorApp className props

303 dict = TypeClassDictionaryConstructorApp className props

279 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

304 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

287 declName (TypeDeclaration ident _) = Just ident

312 declName (TypeDeclaration ident _) = Just ident

288 declName _ = Nothing

313 declName _ = Nothing

289

314

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

291 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

316 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

317 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293 return val

318 return val

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+32−14

@@ -8,9 +8,7 @@

8-- |

9-- This module implements the generic deriving elaboration that takes place during desugaring.

10--

11−module Language.PureScript.Sugar.TypeClasses.Deriving (

11+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

12− deriveInstances

13−) where

14

12

15import Prelude ()

13import Prelude ()

16import Prelude.Compat

14import Prelude.Compat

@@ -32,12 +30,20 @@ import Language.PureScript.Types

32import qualified Language.PureScript.Constants as C

30import qualified Language.PureScript.Constants as C

33

31

34-- | Elaborates deriving instance declarations by code generation.

32-- | Elaborates deriving instance declarations by code generation.

33+deriveInstances

35−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module

34+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)

35+ => Module

36+ -> m Module

36deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

37deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

37

38

38-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

39-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

39-- elaborates that into an instance declaration via code generation.

40-- elaborates that into an instance declaration via code generation.

41+deriveInstance

40−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

42+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

43+ => ModuleName

44+ -> [Declaration]

45+ -> Declaration

46+ -> m Declaration

41deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

47deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

42 | className == Qualified (Just dataGeneric) (ProperName C.generic)

48 | className == Qualified (Just dataGeneric) (ProperName C.generic)

43 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

49 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

@@ -48,7 +54,7 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

48deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

54deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

49deriveInstance _ _ e = return e

55deriveInstance _ _ e = return e

50

56

51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

57+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

52unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

58unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

53unwrapTypeConstructor (TypeApp ty arg) = do

59unwrapTypeConstructor (TypeApp ty arg) = do

54 (tyCon, args) <- unwrapTypeConstructor ty

60 (tyCon, args) <- unwrapTypeConstructor ty

@@ -64,7 +70,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

64typesProxy :: ModuleName

70typesProxy :: ModuleName

65typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

71typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

66

72

73+deriveGeneric

67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

74+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

75+ => ModuleName

76+ -> [Declaration]

77+ -> ProperName 'TypeName

78+ -> [Type]

79+ -> m [Declaration]

68deriveGeneric mn ds tyConNm args = do

80deriveGeneric mn ds tyConNm args = do

69 tyCon <- findTypeDecl tyConNm ds

81 tyCon <- findTypeDecl tyConNm ds

70 toSpine <- mkSpineFunction mn tyCon

82 toSpine <- mkSpineFunction mn tyCon

@@ -75,7 +87,11 @@ deriveGeneric mn ds tyConNm args = do

75 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

87 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

76 ]

88 ]

77

89

90+findTypeDecl

78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

91+ :: (Functor m, MonadError MultipleErrors m)

92+ => ProperName 'TypeName

93+ -> [Declaration]

94+ -> m Declaration

79findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

95findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

80 where

96 where

81 isTypeDecl :: Declaration -> Bool

97 isTypeDecl :: Declaration -> Bool

@@ -92,7 +108,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

92 recordConstructor :: Expr -> Expr

108 recordConstructor :: Expr -> Expr

93 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

109 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

94

110

95− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

111+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

96 mkCtorClause (ctorName, tys) = do

112 mkCtorClause (ctorName, tys) = do

97 idents <- replicateM (length tys) freshIdent'

113 idents <- replicateM (length tys) freshIdent'

98 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

114 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

125 proxy :: Type -> Type

141 proxy :: Type -> Type

126 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

142 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

127

143

128− mkProdClause :: (ProperName, [Type]) -> Expr

144+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

145+ mkProdClause (ctorName, tys) =

146+ ObjectLiteral

129− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

147+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

130− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

148+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

131− ]

149+ ]

132

150

133 mkProductSignature :: Type -> Expr

151 mkProductSignature :: Type -> Expr

134 mkProductSignature r | Just rec <- objectType r =

152 mkProductSignature r | Just rec <- objectType r =

@@ -158,7 +176,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

158 recordBinder :: [Binder] -> Binder

176 recordBinder :: [Binder] -> Binder

159 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

177 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

160

178

161− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

179+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

162 mkAlternative (ctorName, tys) = do

180 mkAlternative (ctorName, tys) = do

163 idents <- replicateM (length tys) freshIdent'

181 idents <- replicateM (length tys) freshIdent'

164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

182 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

39import Language.PureScript.Environment

40import Language.PureScript.Errors

41

42−addDataType ::

42+addDataType

43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

43+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

44− ModuleName ->

44+ => ModuleName

45− DataDeclType ->

45+ -> DataDeclType

46− ProperName ->

46+ -> ProperName 'TypeName

47− [(String, Maybe Kind)] ->

47+ -> [(String, Maybe Kind)]

48− [(ProperName, [Type])] ->

48+ -> [(ProperName 'ConstructorName, [Type])]

49− Kind ->

49+ -> Kind

50− m ()

50+ -> m ()

51addDataType moduleName dtype name args dctors ctorKind = do

52 env <- getEnv

53 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

55 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $

56 addDataConstructor moduleName dtype name (map fst args) dctor tys

57

58−addDataConstructor ::

58+addDataConstructor

59− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

59+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60− ModuleName ->

60+ => ModuleName

61− DataDeclType ->

61+ -> DataDeclType

62− ProperName ->

62+ -> ProperName 'TypeName

63− [String] ->

63+ -> [String]

64− ProperName ->

64+ -> ProperName 'ConstructorName

65− [Type] ->

65+ -> [Type]

66− m ()

66+ -> m ()

67addDataConstructor moduleName dtype name args dctor tys = do

68 env <- getEnv

69 traverse_ checkTypeSynonyms tys

@@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do

73 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]

74 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

75

76−addTypeSynonym ::

76+addTypeSynonym

77− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

77+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

78− ModuleName ->

78+ => ModuleName

79− ProperName ->

79+ -> ProperName 'TypeName

80− [(String, Maybe Kind)] ->

80+ -> [(String, Maybe Kind)]

81− Type ->

81+ -> Type

82− Kind ->

82+ -> Kind

83− m ()

83+ -> m ()

84addTypeSynonym moduleName name args ty kind = do

85 env <- getEnv

86 checkTypeSynonyms ty

87 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

88 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

89

90−valueIsNotDefined ::

90+valueIsNotDefined

91− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

91+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

92− ModuleName ->

92+ => ModuleName

93− Ident ->

93+ -> Ident

94− m ()

94+ -> m ()

95valueIsNotDefined moduleName name = do

96 env <- getEnv

97 case M.lookup (moduleName, name) (names env) of

98 Just _ -> throwError . errorMessage $ RedefinedIdent name

99 Nothing -> return ()

100

101−addValue ::

101+addValue

102− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

102+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

103− ModuleName ->

103+ => ModuleName

104− Ident ->

104+ -> Ident

105− Type ->

105+ -> Type

106− NameKind ->

106+ -> NameKind

107− m ()

107+ -> m ()

108addValue moduleName name ty nameKind = do

109 env <- getEnv

110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

111

112−addTypeClass ::

112+addTypeClass

113− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

113+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

114− ModuleName ->

114+ => ModuleName

115− ProperName ->

115+ -> ProperName 'ClassName

116− [(String, Maybe Kind)] ->

116+ -> [(String, Maybe Kind)]

117− [Constraint] ->

117+ -> [Constraint]

118− [Declaration] ->

118+ -> [Declaration]

119− m ()

119+ -> m ()

120addTypeClass moduleName pn args implies ds =

121 let members = map toPair ds in

122 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 =

125 toPair (PositionedDeclaration _ _ d) = toPair d

126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

127

128−addTypeClassDictionaries ::

128+addTypeClassDictionaries

129− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

129+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

130− Maybe ModuleName ->

130+ => Maybe ModuleName

131− M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->

131+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

132− m ()

132+ -> m ()

133addTypeClassDictionaries mn entries =

134 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

136

137−checkDuplicateTypeArguments ::

137+checkDuplicateTypeArguments

138− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

138+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

139− [String] ->

139+ => [String]

140− m ()

140+ -> m ()

141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

142 throwError . errorMessage $ DuplicateTypeArgument dup

143 where

144 firstDup :: Maybe String

145 firstDup = listToMaybe $ args \\ nub args

146

147−checkTypeClassInstance ::

147+checkTypeClassInstance

148− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

148+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149− ModuleName ->

149+ => ModuleName

150− Type ->

150+ -> Type

151− m ()

151+ -> m ()

152checkTypeClassInstance _ (TypeVar _) = return ()

153checkTypeClassInstance _ (TypeConstructor ctor) = do

154 env <- getEnv

@@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

160-- |

161-- Check that type synonyms are fully-applied in a type

162--

163−checkTypeSynonyms ::

163+checkTypeSynonyms

164− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

164+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165− Type ->

165+ => Type

166− m ()

166+ -> m ()

167checkTypeSynonyms = void . replaceAllTypeSynonyms

168

169-- |

@@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

179--

180-- * Process module imports

181--

182−typeCheckAll :: forall m.

182+typeCheckAll

183+ :: forall m

183− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

184+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

184− ModuleName ->

185+ => ModuleName

185− [DeclarationRef] ->

186+ -> [DeclarationRef]

186− [Declaration] ->

187+ -> [Declaration]

187− m [Declaration]

188+ -> m [Declaration]

188typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189 where

190 where

190 go :: Declaration -> m Declaration

191 go :: Declaration -> m Declaration

@@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

197 addDataType moduleName dtype name args' dctors ctorKind

198 addDataType moduleName dtype name args' dctors ctorKind

198 return $ DataDeclaration dtype name args dctors

199 return $ DataDeclaration dtype name args dctors

199 where

200 where

200− checkNewtype :: [(ProperName, [Type])] -> m ()

201+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()

201 checkNewtype [(_, [_])] = return ()

202 checkNewtype [(_, [_])] = return ()

202 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

@@ -308,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

308 | otherwise = firstDuplicate xs

309 | otherwise = firstDuplicate xs

309 firstDuplicate _ = Nothing

310 firstDuplicate _ = Nothing

310

311

311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()

312+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

312 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313 | moduleName == mn' || any checkType tys' = return ()

314 | moduleName == mn' || any checkType tys' = return ()

314 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

315 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

@@ -335,10 +336,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

335-- Type check an entire module and ensure all types and classes defined within the module that are

336-- Type check an entire module and ensure all types and classes defined within the module that are

336-- required by exported members are also exported.

337-- required by exported members are also exported.

337--

338--

338−typeCheckModule :: forall m.

339+typeCheckModule

340+ :: forall m

339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

341+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

340− Module ->

342+ => Module

341− m Module

343+ -> m Module

342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

344typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

343typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

345typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

344 modify (\s -> s { checkCurrentModule = Just mn })

346 modify (\s -> s { checkCurrentModule = Just mn })

@@ -403,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

403 where

405 where

404 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

406 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

405 go _ = []

407 go _ = []

406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

408+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

407 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

409 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

408 extractCurrentModuleClass _ = Nothing

410 extractCurrentModuleClass _ = Nothing

409

411

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−

16{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

18

3

4+-- |

5+-- Type class entailment

6+--

19−module Language.PureScript.TypeChecker.Entailment (

7+module Language.PureScript.TypeChecker.Entailment (entails) where

20− entails

21−) where

22

8

23import Prelude ()

9import Prelude ()

24import Prelude.Compat

10import Prelude.Compat

@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C

46-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

32-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

47-- return a type class dictionary reference.

33-- return a type class dictionary reference.

48--

34--

49−entails :: forall m.

35+entails

36+ :: forall m

50− (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

37+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

51− ModuleName ->

38+ => ModuleName

52− M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->

39+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

53− Constraint ->

40+ -> Constraint

54− m Expr

41+ -> m Expr

55entails moduleName context = solve

42entails moduleName context = solve

56 where

43 where

57− forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

44+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

58 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

45 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

59 forClassName _ _ = internalError "forClassName: expected qualified class name"

46 forClassName _ _ = internalError "forClassName: expected qualified class name"

60

47

@@ -64,7 +51,7 @@ entails moduleName context = solve

64 ctorModules (TypeApp ty _) = ctorModules ty

51 ctorModules (TypeApp ty _) = ctorModules ty

65 ctorModules _ = Nothing

52 ctorModules _ = Nothing

66

53

67− findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

54+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

68 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

55 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

69

56

70 solve :: Constraint -> m Expr

57 solve :: Constraint -> m Expr

@@ -72,7 +59,7 @@ entails moduleName context = solve

72 dict <- go 0 className tys

59 dict <- go 0 className tys

73 return $ dictionaryValueToValue dict

60 return $ dictionaryValueToValue dict

74 where

61 where

75− go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue

62+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue

76 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

63 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

77 go work className' tys' = do

64 go work className' tys' = do

78 let instances = do

65 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−

16{-# LANGUAGE MultiParamTypeClasses #-}

1{-# LANGUAGE MultiParamTypeClasses #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

@@ -20,12 +5,15 @@

20{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

21{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

22

7

8+-- |

9+-- This module implements the kind checker

10+--

23−module Language.PureScript.TypeChecker.Kinds (

11+module Language.PureScript.TypeChecker.Kinds

24− kindOf,

12+ ( kindOf

25− kindOfWithScopedVars,

13+ , kindOfWithScopedVars

26− kindsOf,

14+ , kindsOf

27− kindsOfAll

15+ , kindsOfAll

28−) where

16+ ) where

29

17

30import Prelude ()

18import Prelude ()

31import Prelude.Compat

19import Prelude.Compat

@@ -54,7 +42,11 @@ freshKind = do

54 return $ KUnknown k

42 return $ KUnknown k

55

43

56-- | Update the substitution to solve a kind constraint

44-- | Update the substitution to solve a kind constraint

45+solveKind

57−solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()

46+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

47+ => Int

48+ -> Kind

49+ -> m ()

58solveKind u k = do

50solveKind u k = do

59 occursCheck u k

51 occursCheck u k

60 modify $ \cs -> cs { checkSubstitution =

52 modify $ \cs -> cs { checkSubstitution =

@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go

75 go other = other

67 go other = other

76

68

77-- | Make sure that an unknown does not occur in a kind

69-- | Make sure that an unknown does not occur in a kind

70+occursCheck

78−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()

71+ :: (Functor m, Applicative m, MonadError MultipleErrors m)

72+ => Int

73+ -> Kind

74+ -> m ()

79occursCheck _ KUnknown{} = return ()

75occursCheck _ KUnknown{} = return ()

80occursCheck u k = void $ everywhereOnKindsM go k

76occursCheck u k = void $ everywhereOnKindsM go k

81 where

77 where

@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k

83 go other = return other

79 go other = return other

84

80

85-- | Unify two kinds

81-- | Unify two kinds

82+unifyKinds

86−unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()

83+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

84+ => Kind

85+ -> Kind

86+ -> m ()

87unifyKinds k1 k2 = do

88 sub <- gets checkSubstitution

89 go (substituteKind sub k1) (substituteKind sub k2)

@@ -100,10 +100,10 @@ unifyKinds k1 k2 = do

100 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'

101

102-- | Infer the kind of a single type

103−kindOf ::

103+kindOf

104− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

104+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

105− Type ->

105+ => Type

106− m Kind

106+ -> m Kind

107kindOf ty = fst <$> kindOfWithScopedVars ty

108

109-- | Infer the kind of a single type, returning the kinds of any scoped type variables

@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =

120 )

121

122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

123−kindsOf ::

123+kindsOf

124− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

124+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

125− Bool ->

125+ => Bool

126− ModuleName ->

126+ -> ModuleName

127− ProperName ->

127+ -> ProperName 'TypeName

128− [(String, Maybe Kind)] ->

128+ -> [(String, Maybe Kind)]

129− [Type] ->

129+ -> [Type]

130− m Kind

130+ -> m Kind

131kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

132 tyCon <- freshKind

133 kargs <- replicateM (length args) freshKind

@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

138 where

139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k

140

141−freshKindVar ::

141+freshKindVar

142− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>

142+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

143− (String, Maybe Kind) ->

143+ => (String, Maybe Kind)

144− Kind ->

144+ -> Kind

145− m (ProperName, Kind)

145+ -> m (ProperName 'TypeName, Kind)

146freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

147freshKindVar (arg, Just kind') kind = do

148 unifyKinds kind kind'

149 return (ProperName arg, kind')

150

151-- | Simultaneously infer the kinds of several mutually recursive type constructors

152−kindsOfAll ::

152+kindsOfAll

153− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

153+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

154− ModuleName ->

154+ => ModuleName

155− [(ProperName, [(String, Maybe Kind)], Type)] ->

155+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

156− [(ProperName, [(String, Maybe Kind)], [Type])] ->

156+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

157− m ([Kind], [Kind])

157+ -> m ([Kind], [Kind])

158kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

159 synVars <- replicateM (length syns) freshKind

160 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

177 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)

178

179-- | Solve the set of kind constraints associated with the data constructors for a type constructor

180+solveTypes

180−solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind

181+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

182+ => Bool

183+ -> [Type]

184+ -> [Kind]

185+ -> Kind

186+ -> m Kind

181solveTypes isData ts kargs tyCon = do

187solveTypes isData ts kargs tyCon = do

182 ks <- traverse (fmap fst . infer) ts

188 ks <- traverse (fmap fst . infer) ts

183 when isData $ do

189 when isData $ do

@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

195starIfUnknown k = k

201starIfUnknown k = k

196

202

197-- | Infer a kind for a type

203-- | Infer a kind for a type

204+infer

198−infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

205+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

206+ => Type

207+ -> m (Kind, [(String, Kind)])

199infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

200

209

210+infer'

211+ :: forall m

201−infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

212+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

213+ => Type

214+ -> m (Kind, [(String, Kind)])

202infer' (ForAll ident ty _) = do

215infer' (ForAll ident ty _) = do

203 k1 <- freshKind

216 k1 <- freshKind

204 Just moduleName <- checkCurrentModule <$> get

217 Just moduleName <- checkCurrentModule <$> get

@@ -250,7 +263,7 @@ infer' other = (, []) <$> go other

250 return $ Row k1

263 return $ Row k1

251 go (ConstrainedType deps ty) = do

264 go (ConstrainedType deps ty) = do

252 forM_ deps $ \(className, tys) -> do

265 forM_ deps $ \(className, tys) -> do

253− k <- go $ foldl TypeApp (TypeConstructor className) tys

266+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

254 unifyKinds k Star

267 unifyKinds k Star

255 k <- go ty

268 k <- go ty

256 unifyKinds k Star

269 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−

16{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

@@ -20,6 +5,9 @@

20{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

21{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

22

7

8+-- |

9+-- Monads for type checking and type inference and associated data types

10+--

23module Language.PureScript.TypeChecker.Monad where

11module Language.PureScript.TypeChecker.Monad where

24

12

25import Prelude ()

13import Prelude ()

@@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

69type Unknown = Int

57type Unknown = Int

70

58

71-- | Temporarily bind a collection of names to values

59-- | Temporarily bind a collection of names to values

60+bindNames

61+ :: MonadState CheckState m

72−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a

62+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

63+ -> m a

64+ -> m a

73bindNames newNames action = do

65bindNames newNames action = do

74 orig <- get

66 orig <- get

75 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

67 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -78,7 +70,11 @@ bindNames newNames action = do

78 return a

70 return a

79

71

80-- | Temporarily bind a collection of names to types

72-- | Temporarily bind a collection of names to types

73+bindTypes

74+ :: MonadState CheckState m

81−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a

75+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

76+ -> m a

77+ -> m a

82bindTypes newNames action = do

78bindTypes newNames action = do

83 orig <- get

79 orig <- get

84 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

80 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -87,7 +83,12 @@ bindTypes newNames action = do

87 return a

83 return a

88

84

89-- | Temporarily bind a collection of names to types

85-- | Temporarily bind a collection of names to types

86+withScopedTypeVars

90−withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a

87+ :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)

88+ => ModuleName

89+ -> [(String, Kind)]

90+ -> m a

91+ -> m a

91withScopedTypeVars mn ks ma = do

92withScopedTypeVars mn ks ma = do

92 orig <- get

93 orig <- get

93 forM_ ks $ \(name, _) ->

94 forM_ ks $ \(name, _) ->

@@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do

96 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

97 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

97

98

98-- | Temporarily make a collection of type class dictionaries available

99-- | Temporarily make a collection of type class dictionaries available

100+withTypeClassDictionaries

101+ :: MonadState CheckState m

99−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

102+ => [TypeClassDictionaryInScope]

103+ -> m a

104+ -> m a

100withTypeClassDictionaries entries action = do

105withTypeClassDictionaries entries action = do

101 orig <- get

106 orig <- get

102 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 ]

107 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

106 return a

111 return a

107

112

108-- | Get the currently available map of type class dictionaries

113-- | Get the currently available map of type class dictionaries

109−getTypeClassDictionaries ::

114+getTypeClassDictionaries

110− (Functor m, MonadState CheckState m) =>

115+ :: (Functor m, MonadState CheckState m)

111− m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

116+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

112getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

113

118

114-- | Lookup type class dictionaries in a module.

119-- | Lookup type class dictionaries in a module.

115−lookupTypeClassDictionaries ::

120+lookupTypeClassDictionaries

116− (Functor m, MonadState CheckState m) =>

121+ :: (Functor m, MonadState CheckState m)

117− Maybe ModuleName ->

122+ => Maybe ModuleName

118− m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

123+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

119lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

124lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

120

125

121-- | Temporarily bind a collection of names to local variables

126-- | Temporarily bind a collection of names to local variables

127+bindLocalVariables

122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

128+ :: (Functor m, MonadState CheckState m)

129+ => ModuleName

130+ -> [(Ident, Type, NameVisibility)]

131+ -> m a

132+ -> m a

123bindLocalVariables moduleName bindings =

133bindLocalVariables moduleName bindings =

124 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

134 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

125

135

126-- | Temporarily bind a collection of names to local type variables

136-- | Temporarily bind a collection of names to local type variables

137+bindLocalTypeVariables

127−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

138+ :: (Functor m, MonadState CheckState m)

139+ => ModuleName

140+ -> [(ProperName 'TypeName, Kind)]

141+ -> m a

142+ -> m a

128bindLocalTypeVariables moduleName bindings =

143bindLocalTypeVariables moduleName bindings =

129 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

130

145

@@ -145,7 +160,11 @@ preservingNames action = do

145 return a

160 return a

146

161

147-- | Lookup the type of a value by name in the @Environment@

162-- | Lookup the type of a value by name in the @Environment@

163+lookupVariable

148−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

164+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

165+ => ModuleName

166+ -> Qualified Ident

167+ -> m Type

149lookupVariable currentModule (Qualified moduleName var) = do

168lookupVariable currentModule (Qualified moduleName var) = do

150 env <- getEnv

169 env <- getEnv

151 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do

153 Just (ty, _, _) -> return ty

172 Just (ty, _, _) -> return ty

154

173

155-- | Lookup the visibility of a value by name in the @Environment@

174-- | Lookup the visibility of a value by name in the @Environment@

175+getVisibility

156−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

176+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

177+ => ModuleName

178+ -> Qualified Ident

179+ -> m NameVisibility

157getVisibility currentModule (Qualified moduleName var) = do

180getVisibility currentModule (Qualified moduleName var) = do

158 env <- getEnv

181 env <- getEnv

159 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

182 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do

161 Just (_, _, vis) -> return vis

184 Just (_, _, vis) -> return vis

162

185

163-- | Assert that a name is visible

186-- | Assert that a name is visible

187+checkVisibility

164−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

188+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

189+ => ModuleName

190+ -> Qualified Ident

191+ -> m ()

165checkVisibility currentModule name@(Qualified _ var) = do

192checkVisibility currentModule name@(Qualified _ var) = do

166 vis <- getVisibility currentModule name

193 vis <- getVisibility currentModule name

167 case vis of

194 case vis of

@@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do

169 _ -> return ()

196 _ -> return ()

170

197

171-- | Lookup the kind of a type by name in the @Environment@

198-- | Lookup the kind of a type by name in the @Environment@

199+lookupTypeVariable

172−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

200+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

201+ => ModuleName

202+ -> Qualified (ProperName 'TypeName)

203+ -> m Kind

173lookupTypeVariable currentModule (Qualified moduleName name) = do

204lookupTypeVariable currentModule (Qualified moduleName name) = do

174 env <- getEnv

205 env <- getEnv

175 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

206 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

468-- |

469-- Check the type of a value

470--

471+check'

471−check' :: forall m.

472+ :: forall m

472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

473+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

473− Expr ->

474+ => Expr

474− Type ->

475+ -> Type

475− m Expr

476+ -> m Expr

476check' val (ForAll ident ty _) = do

477check' val (ForAll ident ty _) = do

477 scope <- newSkolemScope

478 scope <- newSkolemScope

478 sko <- newSkolemConstant

479 sko <- newSkolemConstant

@@ -492,7 +493,11 @@ check' val t@(ConstrainedType constraints ty) = do

492 where

493 where

493 -- | Add a dictionary for the constraint to the scope, and dictionaries

494 -- | Add a dictionary for the constraint to the scope, and dictionaries

494 -- for all implied superclass instances.

495 -- for all implied superclass instances.

496+ newDictionaries

497+ :: [(Qualified (ProperName 'ClassName), Integer)]

498+ -> Qualified Ident

499+ -> (Qualified (ProperName 'ClassName), [Type])

495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]

500+ -> m [TypeClassDictionaryInScope]

496 newDictionaries path name (className, instanceTy) = do

501 newDictionaries path name (className, instanceTy) = do

497 tcs <- gets (typeClasses . checkEnv)

502 tcs <- gets (typeClasses . checkEnv)

498 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

503 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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16

2

17module Language.PureScript.TypeClassDictionaries where

3module Language.PureScript.TypeClassDictionaries where

@@ -29,9 +15,9 @@ data TypeClassDictionaryInScope

29 -- | The identifier with which the dictionary can be accessed at runtime

15 -- | The identifier with which the dictionary can be accessed at runtime

30 tcdName :: Qualified Ident

16 tcdName :: Qualified Ident

31 -- | How to obtain this instance via superclass relationships

17 -- | How to obtain this instance via superclass relationships

32− , tcdPath :: [(Qualified ProperName, Integer)]

18+ , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

33 -- | The name of the type class to which this type class instance applies

19 -- | The name of the type class to which this type class instance applies

34− , tcdClassName :: Qualified ProperName

20+ , tcdClassName :: Qualified (ProperName 'ClassName)

35 -- | The types to which this type class instance applies

21 -- | The types to which this type class instance applies

36 , tcdInstanceTypes :: [Type]

22 , tcdInstanceTypes :: [Type]

37 -- | Type class dependencies which must be satisfied to construct this dictionary

23 -- | Type class dependencies which must be satisfied to construct this dictionary

@@ -58,5 +44,5 @@ data DictionaryValue

58 -- |

44 -- |

59 -- A subclass dictionary

45 -- A subclass dictionary

60 --

46 --

61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

47+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer

62 deriving (Show, Read, Ord, Eq)

48 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−

16{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

17{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

19

4

5+-- |

6+-- Data types for types

7+--

20module Language.PureScript.Types where

8module Language.PureScript.Types where

21

9

22import Prelude ()

10import Prelude ()

@@ -60,7 +48,7 @@ data Type

60 -- |

48 -- |

61 -- A type constructor

49 -- A type constructor

62 --

50 --

63− | TypeConstructor (Qualified ProperName)

51+ | TypeConstructor (Qualified (ProperName 'TypeName))

64 -- |

52 -- |

65 -- A type application

53 -- A type application

66 --

54 --

@@ -106,7 +94,7 @@ data Type

106-- |

94-- |

107-- A typeclass constraint

95-- A typeclass constraint

108--

96--

109−type Constraint = (Qualified ProperName, [Type])

97+type Constraint = (Qualified (ProperName 'ClassName), [Type])

110

98

111$(A.deriveJSON A.defaultOptions ''Type)

99$(A.deriveJSON A.defaultOptions ''Type)

112

100