Skip to content

Commit 8ca3d1e

Browse files
garybgaryb
committed
Distinguish between the different ProperNames
1 parent 3bec40c commit 8ca3d1e

39 files changed

+805
-673
lines changed

‎hierarchy/Main.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414
-----------------------------------------------------------------------------
1515

1616
{-# LANGUAGE TupleSections #-}
17+
{-# LANGUAGE DataKinds #-}
1718

1819
module Main where
1920

@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions
3839
, hierarchyOutput :: Maybe FilePath
3940
}
4041

41-
newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
42+
newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }
4243
deriving Eq
4344

4445
instance Show SuperMap where

‎psci/Completion.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE DataKinds #-}
2+
13
module Completion where
24

35
import Prelude ()
@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf
184186
nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
185187
nubOnFst = nubBy ((==) `on` fst)
186188

187-
typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
189+
typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]
188190
typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
189191
where
190-
getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
192+
getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)
191193
getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
192194
getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
193195
getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
204206
getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
205207
getDeclNames _ = []
206208

207-
dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
209+
dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
208210
dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
209211
where
210-
go :: P.Declaration -> [(N.ProperName, P.Declaration)]
212+
go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
211213
go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
212214
go (P.PositionedDeclaration _ _ d) = go d
213215
go _ = []

‎psci/PSCi.hs‎

Lines changed: 20 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33
{-# LANGUAGE RecordWildCards #-}
44
{-# LANGUAGE TupleSections #-}
5+
{-# LANGUAGE DataKinds #-}
56

67
-- |
78
-- PureScript Compiler Interactive.
@@ -326,7 +327,7 @@ handleShowImportedModules = do
326327
showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
327328
showRef (P.ValueRef ident) = N.runIdent ident
328329
showRef (P.TypeClassRef pn) = N.runProperName pn
329-
showRef (P.ProperRef pn) = N.runProperName pn
330+
showRef (P.ProperRef pn) = pn
330331
showRef (P.TypeInstanceRef ident) = N.runIdent ident
331332
showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
332333
showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
@@ -391,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) =
391392
showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
392393
showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
393394

394-
findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
395+
findTypeClass
396+
:: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
397+
-> P.Qualified (P.ProperName 'P.ClassName)
398+
-> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
395399
findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
396400

397-
showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box
401+
showTypeClass
402+
:: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
403+
-> Maybe Box.Box
398404
showTypeClass (_, Nothing) = Nothing
399405
showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
400406
let constraints =
@@ -418,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) =
418424
Box.// Box.moveRight 2 classBody
419425

420426

421-
findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
427+
findType
428+
:: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)
429+
-> P.Qualified (P.ProperName 'P.TypeName)
430+
-> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
422431
findType envTypes name = (name, M.lookup name envTypes)
423432

424-
showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
425-
-> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])
426-
-> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)
427-
-> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
428-
-> Maybe Box.Box
433+
showType
434+
:: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
435+
-> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
436+
-> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
437+
-> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
438+
-> Maybe Box.Box
429439
showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
430440
case (typ, M.lookup n typeSynonymsEnv) of
431441
(Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
432-
if M.member n typeClassesEnv
442+
if M.member (fmap P.coerceProperName n) typeClassesEnv
433443
then
434444
Nothing
435445
else

‎purescript.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -178,6 +178,8 @@ library
178178
Control.Monad.Supply.Class
179179

180180
System.IO.UTF8
181+
182+
extensions: DataKinds
181183
exposed: True
182184
buildable: True
183185
hs-source-dirs: src

‎src/Language/PureScript.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16-
{-# LANGUAGE DataKinds #-}
1716
{-# LANGUAGE FlexibleContexts #-}
1817
{-# LANGUAGE ScopedTypeVariables #-}
1918

‎src/Language/PureScript/AST/Binders.hs‎

Lines changed: 4 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,8 @@
1-
-----------------------------------------------------------------------------
2-
--
3-
-- Module : Language.PureScript.AST.Binders
4-
-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5-
-- License : MIT
6-
--
7-
-- Maintainer : Phil Freeman <paf31@cantab.net>
8-
-- Stability : experimental
9-
-- Portability :
10-
--
11-
-- | Case binders
12-
--
13-
-----------------------------------------------------------------------------
14-
151
{-# LANGUAGE DeriveDataTypeable #-}
162

3+
-- |
4+
-- Case binders
5+
--
176
module Language.PureScript.AST.Binders where
187

198
import qualified Data.Data as D
@@ -54,7 +43,7 @@ data Binder
5443
-- |
5544
-- A binder which matches a data constructor
5645
--
57-
| ConstructorBinder (Qualified ProperName) [Binder]
46+
| ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
5847
-- |
5948
-- A binder which matches a record and binds its properties
6049
--

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -60,15 +60,15 @@ data DeclarationRef
6060
-- |
6161
-- A type constructor with data constructors
6262
--
63-
= TypeRef ProperName (Maybe [ProperName])
63+
= TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
6464
-- |
6565
-- A value
6666
--
6767
| ValueRef Ident
6868
-- |
6969
-- A type class
7070
--
71-
| TypeClassRef ProperName
71+
| TypeClassRef (ProperName 'ClassName)
7272
-- |
7373
-- A type class instance, created during typeclass desugaring (name, class name, instance types)
7474
--
@@ -80,7 +80,7 @@ data DeclarationRef
8080
-- |
8181
-- An unspecified ProperName ref. This will be replaced with a TypeClassRef
8282
-- or TypeRef during name desugaring.
83-
| ProperRef ProperName
83+
| ProperRef String
8484
-- |
8585
-- A declaration reference with source position information
8686
--
@@ -108,7 +108,7 @@ isModuleRef _ = False
108108
-- are the duplicate refs with data constructors elided, and then a separate
109109
-- list of duplicate data constructors.
110110
--
111-
findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])
111+
findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])
112112
findDuplicateRefs refs =
113113
let positionless = stripPosInfo `map` refs
114114
simplified = simplifyTypeRefs `map` positionless
@@ -154,15 +154,15 @@ data Declaration
154154
-- |
155155
-- A data type declaration (data or newtype, name, arguments, data constructors)
156156
--
157-
= DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
157+
= DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
158158
-- |
159159
-- A minimal mutually recursive set of data type declarations
160160
--
161161
| DataBindingGroupDeclaration [Declaration]
162162
-- |
163163
-- A type synonym declaration (name, arguments, type)
164164
--
165-
| TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
165+
| TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type
166166
-- |
167167
-- A type declaration for a value (name, ty)
168168
--
@@ -182,7 +182,7 @@ data Declaration
182182
-- |
183183
-- A data type foreign import (name, kind)
184184
--
185-
| ExternDataDeclaration ProperName Kind
185+
| ExternDataDeclaration (ProperName 'TypeName) Kind
186186
-- |
187187
-- A fixity declaration (fixity data, operator name, value the operator is an alias for)
188188
--
@@ -195,12 +195,12 @@ data Declaration
195195
-- |
196196
-- A type class declaration (name, argument, implies, member declarations)
197197
--
198-
| TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
198+
| TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]
199199
-- |
200200
-- A type instance declaration (name, dependencies, class name, instance types, member
201201
-- declarations)
202202
--
203-
| TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody
203+
| TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody
204204
-- |
205205
-- A declaration with source position information
206206
--
@@ -390,7 +390,7 @@ data Expr
390390
-- |
391391
-- A data constructor
392392
--
393-
| Constructor (Qualified ProperName)
393+
| Constructor (Qualified (ProperName 'ConstructorName))
394394
-- |
395395
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
396396
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
@@ -412,23 +412,23 @@ data Expr
412412
-- An application of a typeclass dictionary constructor. The value should be
413413
-- an ObjectLiteral.
414414
--
415-
| TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
415+
| TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr
416416
-- |
417417
-- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
418418
-- placeholders will be replaced with actual expressions representing type classes dictionaries which
419419
-- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
420420
-- at superclass implementations when searching for a dictionary, the type class name and
421421
-- instance type, and the type class dictionaries in scope.
422422
--
423-
| TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
423+
| TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
424424
-- |
425425
-- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
426426
--
427-
| TypeClassDictionaryAccessor (Qualified ProperName) Ident
427+
| TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident
428428
-- |
429429
-- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
430430
--
431-
| SuperClassDictionary (Qualified ProperName) [Type]
431+
| SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
432432
-- |
433433
-- A value with source position information
434434
--

‎src/Language/PureScript/AST/Exported.hs‎

Lines changed: 36 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,7 @@
1-
2-
module Language.PureScript.AST.Exported (
3-
exportedDeclarations,
4-
isExported
5-
) where
1+
module Language.PureScript.AST.Exported
2+
( exportedDeclarations
3+
, isExported
4+
) where
65

76
import Control.Category ((>>>))
87
import Data.Maybe (mapMaybe)
@@ -23,12 +22,12 @@ import Language.PureScript.Names
2322
-- instances will be incorrectly removed in some cases.
2423
--
2524
exportedDeclarations :: Module -> [Declaration]
26-
exportedDeclarations (Module _ _ _ decls exps) = go decls
25+
exportedDeclarations (Module _ _ mn decls exps) = go decls
2726
where
2827
go = flattenDecls
2928
>>> filter (isExported exps)
3029
>>> map (filterDataConstructors exps)
31-
>>> filterInstances exps
30+
>>> filterInstances mn exps
3231

3332
-- |
3433
-- Filter out all data constructors from a declaration which are not exported.
@@ -52,10 +51,15 @@ filterDataConstructors _ other = other
5251
-- produce incorrect results if this is not the case - for example, type class
5352
-- instances will be incorrectly removed in some cases.
5453
--
55-
filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
56-
filterInstances Nothing = id
57-
filterInstances (Just exps) =
58-
let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
54+
filterInstances
55+
:: ModuleName
56+
-> Maybe [DeclarationRef]
57+
-> [Declaration]
58+
-> [Declaration]
59+
filterInstances _ Nothing = id
60+
filterInstances mn (Just exps) =
61+
let refs = Left `map` mapMaybe typeClassName exps
62+
++ Right `map` mapMaybe typeName exps
5963
in filter (all (visibleOutside refs) . typeInstanceConstituents)
6064
where
6165
-- Given a Qualified ProperName, and a list of all exported types and type
@@ -65,31 +69,42 @@ filterInstances (Just exps) =
6569
-- * the name is defined in the same module and is exported,
6670
-- * the name is defined in a different module (and must be exported from
6771
-- that module; the code would fail to compile otherwise).
68-
visibleOutside _ (Qualified (Just _) _) = True
69-
visibleOutside refs (Qualified Nothing n) = n `elem` refs
70-
72+
visibleOutside
73+
:: [Either (ProperName 'ClassName) (ProperName 'TypeName)]
74+
-> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))
75+
-> Bool
76+
visibleOutside refs q
77+
| either checkQual checkQual q = True
78+
| otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs
79+
80+
-- Check that a qualified name is qualified for a different module
81+
checkQual :: Qualified a -> Bool
82+
checkQual q = isQualified q && not (isQualifiedWith mn q)
83+
84+
typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)
7185
typeName (TypeRef n _) = Just n
7286
typeName (PositionedDeclarationRef _ _ r) = typeName r
7387
typeName _ = Nothing
7488

89+
typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
7590
typeClassName (TypeClassRef n) = Just n
7691
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
7792
typeClassName _ = Nothing
7893

7994
-- |
8095
-- Get all type and type class names referenced by a type instance declaration.
8196
--
82-
typeInstanceConstituents :: Declaration -> [Qualified ProperName]
97+
typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]
8398
typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
84-
className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
99+
Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
85100
where
86101

87-
fromConstraint (name, tys') = name : concatMap fromType tys'
102+
fromConstraint (name, tys') = Left name : concatMap fromType tys'
88103
fromType = everythingOnTypes (++) go
89104

90105
-- Note that type synonyms are disallowed in instance declarations, so
91106
-- we don't need to handle them here.
92-
go (TypeConstructor n) = [n]
107+
go (TypeConstructor n) = [Right n]
93108
go (ConstrainedType cs _) = concatMap fromConstraint cs
94109
go _ = []
95110

@@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps
118133
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
119134
matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
120135

121-
matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'
122-
matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'
136+
matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'
137+
matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'
123138

124139
matches (PositionedDeclaration _ _ d) r = d `matches` r
125140
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
@@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps
129144
-- Test if a data constructor for a given type is exported, given a module's
130145
-- export list. Prefer 'exportedDeclarations' to this function, where possible.
131146
--
132-
isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
147+
isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
133148
isDctorExported _ Nothing _ = True
134149
isDctorExported ident (Just exps) ctor = test `any` exps
135150
where

0 commit comments

Comments
 (0)