3ad48f1 · rowtype-yoga/purescript-native

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

Separate the `Op` and `Ident` namespaces

* Separate operator and ident namespaces, some general name-related updates * Fixes #2064 (#2107)

commit3ad48f1e8931bd41919abe21883cb20e5ce5222f authorGary Burgess <gary.burgess@gmail.com> dateWed 11 May 2016, 12:27 (10 years ago) parent2dd0f79

82 files changed+1499−1334

compare with golang

unifiedsplit

CONTRIBUTORS.md+1

@@ -31,6 +31,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

3131- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

3232- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

3333- [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

34+- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

3435- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

3536- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

3637- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

examples/docs/src/OldOperators.pursdeleted−10

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

1−

2−-- Remove this after 0.9.

3−module OldOperators (module OldOperators2) where

4−

5−import OldOperators2

6−

7−module OldOperators2 where

8−

9−(>>) :: forall a. a -> a -> a

10−(>>) a b = b

examples/failing/1733.purs+1−1

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

1−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

22module Main where

44import Thingy as Thing

examples/failing/1825.purs+4−4

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

1−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

33module Main where

55data W = X | Y | Z

7−bad X a = a

8−bad Y _ = a

9−bad Z a = a

7+bad X a = a

8+bad Y _ = a

9+bad Z a = a

examples/failing/Arrays.purs+2−4

@@ -1,8 +1,6 @@

11-- @shouldFailWith TypesDoNotUnify

22module Main where

4−import Prelude

4+foreign import ix :: forall a. Array a -> Int -> a

6−foreign import (!!) :: forall a. Array a -> Int -> a

7−

8−test = \arr -> arr !! (0 !! 0)

6+test = \arr -> arr `ix` (0 `ix` 0)

examples/failing/ExportExplicit.purs+1−1

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

1−-- @shouldFailWith UnknownExportValue

1+-- @shouldFailWith UnknownExport

22-- should fail as z does not exist in the module

33module M1 (x, y, z) where

examples/failing/ExportExplicit1.purs+1−1

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

1−-- @shouldFailWith UnknownDataConstructor

1+-- @shouldFailWith UnknownName

22module Main where

44import M1

examples/failing/ExportExplicit3.purs+1−1

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

1−-- @shouldFailWith UnknownDataConstructor

1+-- @shouldFailWith UnknownName

22module Main where

44import M1

examples/failing/ImportExplicit.purs+1−1

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

1−-- @shouldFailWith UnknownImportType

1+-- @shouldFailWith UnknownImport

22module Main where

44import M1 (X(..))

examples/failing/ImportModule.purs+1−1

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

1−-- @shouldFailWith UnknownModule

1+-- @shouldFailWith UnknownName

22module Main where

44import M1

examples/failing/MultipleErrors2.purs+2−2

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

1−-- @shouldFailWith UnknownValue

2−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

2+-- @shouldFailWith UnknownName

33module MultipleErrors2 where

55import Prelude

examples/failing/MultipleTypeOpFixities.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith MultipleTypeOpFixities

2+module MultipleTypeOpFixities where

4+import Prelude

6+type Op x y = Op x y

8+infix 2 type Op as !?

9+infix 2 type Op as !?

examples/failing/MultipleValueOpFixities.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith MultipleValueOpFixities

2+module MultipleValueOpFixities where

4+import Prelude

6+add x y = x + y

8+infix 2 add as !?

9+infix 2 add as !?

examples/failing/RedefinedFixity.pursdeleted−9

@@ -1,9 +0,0 @@

1−-- @shouldFailWith MultipleFixities

2−module RedefinedFixity where

3−

4−import Prelude

5−

6−(!?) x y = x + y

7−

8−infix 2 !?

9−infix 2 !?

examples/failing/UnknownType.purs+1−1

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

1−-- @shouldFailWith UnknownType

1+-- @shouldFailWith UnknownName

22module Main where

44import Prelude

examples/passing/Dollar.purs+3−3

@@ -2,10 +2,10 @@ module Main where

33import Prelude ()

5−($) :: forall a b. (a -> b) -> a -> b

6−($) f x = f x

5+applyFn :: forall a b. (a -> b) -> a -> b

6+applyFn f x = f x

8−infixr 1000 $

8+infixr 1000 applyFn as $

1010id x = x

1111

examples/passing/Functions.purs+2−5

@@ -1,6 +1,7 @@

11module Main where

33import Prelude

4+import Control.Monad.Eff.Console (log)

56test1 = \_ -> 0.0

@@ -8,8 +9,4 @@ test2 = \a b -> a + b + 1.0

910test3 = \a -> a

1011

11−test4 = \(%%) -> 1.0 %% 2.0

12−

13−test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0

14−

15−main = Control.Monad.Eff.Console.log "Done"

12+main = log "Done"

examples/passing/OperatorSections.purs+3−3

@@ -12,7 +12,7 @@ main = do

1212 let foo = { x: 2.0 }

1313 assert $ (_ / foo.x) 4.0 == 2.0

1414 assert $ (foo.x / _) 4.0 == 0.5

15− let (//) x y = x.x / y.x

16− assert $ (_ // foo { x = 4.0 }) { x: 4.0 } == 1.0

17− assert $ (foo { x = 4.0 } // _) { x: 4.0 } == 1.0

15+ let div x y = x.x / y.x

16+ assert $ (_ `div` foo { x = 4.0 }) { x: 4.0 } == 1.0

17+ assert $ (foo { x = 4.0 } `div` _) { x: 4.0 } == 1.0

1818 log "Done"

examples/passing/Operators.purs+19−23

@@ -4,8 +4,10 @@ import Prelude

44import Control.Monad.Eff

55import Control.Monad.Eff.Console

7−(?!) :: forall a. a -> a -> a

8−(?!) x _ = x

7+op1 :: forall a. a -> a -> a

8+op1 x _ = x

10+infix 4 op1 as ?!

911

1012bar :: String -> String -> String

1113bar = \s1 s2 -> s1 <> s2

@@ -21,22 +23,26 @@ k = \x -> \y -> x

2123

2224test4 = 1 `k` 2

2325

24−infixl 5 %%

26+op2 :: Number -> Number -> Number

27+op2 x y = x * y + y

2528

26−(%%) :: Number -> Number -> Number

27−(%%) x y = x * y + y

29+infixl 5 op2 as %%

2830

2931test5 = 1.0 %% 2.0 %% 3.0

3032

3133test6 = ((\x -> x) `k` 2.0) 3.0

3234

33−(<+>) :: String -> String -> String

34−(<+>) = \s1 s2 -> s1 <> s2

35+op3 :: String -> String -> String

36+op3 = \s1 s2 -> s1 <> s2

37+

38+infix 4 op3 as <+>

3539

3640test7 = "Hello" <+> "World!"

3741

38−(@@) :: forall a b. (a -> b) -> a -> b

39−(@@) = \f x -> f x

42+op4 :: forall a b. (a -> b) -> a -> b

43+op4 = \f x -> f x

44+

45+infix 4 op4 as @@

4046

4147foo :: String -> String

4248foo = \s -> s

@@ -47,14 +53,12 @@ test9 = Main.foo @@ "Hello World"

4753

4854test10 = "Hello" `Main.bar` "World"

4955

50−(...) :: forall a. Array a -> Array a -> Array a

51−(...) = \as -> \bs -> as

56+op5 :: forall a. Array a -> Array a -> Array a

57+op5 = \as -> \bs -> as

5258

53−test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0]

59+infix 4 op5 as ...

5460

55−test12 (<%>) a b = a <%> b

56−

57−test13 = \(<%>) a b -> a <%> b

61+test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0]

5862

5963test14 :: Number -> Number -> Boolean

6064test14 a b = a < b

@@ -71,11 +75,6 @@ test18 = negate $ negate 1.0

7175test19 :: Number

7276test19 = negate $ negate (-1.0)

7377

74−test20 :: Number

75−test20 = 1.0 @ 2.0

76− where

77− (@) x y = x + y * y

78−

7978main = do

8079 let t1 = test1 1.0 2.0 (\x y -> x + y)

8180 let t2 = test2

@@ -88,12 +87,9 @@ main = do

8887 let t9 = test9

8988 let t10 = test10

9089 let t11 = test11

91− let t12 = test12 k 1.0 2.0

92− let t13 = test13 k 1.0 2.0

9390 let t14 = test14 1.0 2.0

9491 let t15 = test15 1.0 2.0

9592 let t17 = test17

9693 let t18 = test18

9794 let t19 = test19

98− let t20 = test20

9995 log "Done"

examples/passing/RebindableSyntax.purs+4−2

@@ -12,8 +12,10 @@ example1 = do

1212 where

1313 bind x f = x <> f unit

1414

15−(*>) :: forall f a b. (Apply f) => f a -> f b -> f b

16−(*>) fa fb = const id <$> fa <*> fb

15+applySecond :: forall f a b. (Apply f) => f a -> f b -> f b

16+applySecond fa fb = const id <$> fa <*> fb

17+

18+infixl 4 applySecond as *>

1719

1820newtype Const a b = Const a

1921

examples/passing/RedefinedFixity/M1.purs+3−4

@@ -1,7 +1,6 @@

11module M1 where

3−import Prelude ()

3+applyFn :: forall a b. (forall c d. c -> d) -> a -> b

4+applyFn f a = f a

5−($) f a = f a

6−

7−infixr 1000 $

6+infixr 1000 applyFn as $

examples/passing/UnicodeType.purs+4−5

@@ -1,11 +1,12 @@

11module Main where

33import Prelude

4+import Control.Monad.Eff.Console (log)

5−class (Monad m) ⇐ Monad1 m where

6+class Monad m ⇐ Monad1 m where

67 f1 :: Int

8−class (Monad m) <= Monad2 m where

9+class Monad m <= Monad2 m where

910 f2 :: Int

1011

1112f ∷ ∀ m. Monad m ⇒ Int → m Int

@@ -18,6 +19,4 @@ f' n = do

1819 n' <- pure n

1920 pure n'

2021

21−(←→) a b = a ←→ b

22−

23−main = Control.Monad.Eff.Console.log "Done"

22+main = log "Done"

psc-ide-client/Main.hs+1−1

@@ -35,7 +35,7 @@ main = do

3535client :: PortID -> IO ()

3636client port = do

3737 h <-

38− connectTo "localhost" port `catch`

38+ connectTo "127.0.0.1" port `catch`

3939 (\(SomeException e) ->

4040 putStrLn

4141 ("Couldn't connect to psc-ide-server on port: " ++

psc-ide-server/Main.hs+5−3

@@ -39,10 +39,10 @@ import Language.PureScript.Ide.Util

3939import Language.PureScript.Ide.Error

4040import Language.PureScript.Ide.Types

4141import Language.PureScript.Ide.Watcher

42−import Network hiding (socketPort)

42+import Network hiding (socketPort, accept)

4343import Network.BSD (getProtocolNumber)

4444import Network.Socket hiding (PortNumber, Type,

45− accept, sClose)

45+ sClose)

4646import Options.Applicative

4747import System.Directory

4848import System.FilePath

@@ -166,7 +166,9 @@ acceptCommand sock = do

166166 pure (cmd, h)

167167 where

168168 acceptConnection = liftIO $ do

169− (h,_,_) <- accept sock

169+ -- Use low level accept to prevent accidental reverse name resolution

170+ (s,_) <- accept sock

171+ h <- socketToHandle s ReadWriteMode

170172 hSetEncoding h utf8

171173 hSetBuffering h LineBuffering

172174 pure h

psci/PSCi.hs+2−1

@@ -253,8 +253,9 @@ handleShowImportedModules = do

253253

254254 showRef :: P.DeclarationRef -> String

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

256− showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")"

256+ showRef (P.TypeOpRef op) = "type " ++ N.showOp op

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

258+ showRef (P.ValueOpRef op) = N.showOp op

258259 showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn

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

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

psci/PSCi/Message.hs+2−3

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

11module PSCi.Message where

3−

43import Data.List (intercalate)

5−import qualified PSCi.Directive as D

65import PSCi.Types

6+import qualified PSCi.Directive as D

88-- Messages

@@ -50,4 +50,3 @@ prologueMessage = intercalate "\n"

5050--

5151quitMessage :: String

5252quitMessage = "See ya!"

53−

purescript.cabal+2−1

@@ -194,9 +194,10 @@ library

194194 Language.PureScript.Sugar.CaseDeclarations

195195 Language.PureScript.Sugar.DoNotation

196196 Language.PureScript.Sugar.Names

197+ Language.PureScript.Sugar.Names.Common

197198 Language.PureScript.Sugar.Names.Env

198− Language.PureScript.Sugar.Names.Imports

199199 Language.PureScript.Sugar.Names.Exports

200+ Language.PureScript.Sugar.Names.Imports

200201 Language.PureScript.Sugar.ObjectWildcards

201202 Language.PureScript.Sugar.Operators

202203 Language.PureScript.Sugar.Operators.Common

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

@@ -35,7 +35,7 @@ data Binder

3535 -- A operator alias binder. During the rebracketing phase of desugaring,

3636 -- this data constructor will be removed.

3737 --

38− | OpBinder (Qualified Ident)

38+ | OpBinder (Qualified (OpName 'ValueOpName))

3939 -- |

4040 -- Binary operator application. During the rebracketing phase of desugaring,

4141 -- this data constructor will be removed.

src/Language/PureScript/AST/Declarations.hs+50−51

@@ -10,8 +10,6 @@ import Prelude.Compat

1010import Control.Monad.Identity

1111

1212import Data.Aeson.TH

13−import Data.List (nub, (\\))

14−import Data.Maybe (mapMaybe)

1513import qualified Data.Map as M

1614

1715import Language.PureScript.AST.Binders

@@ -60,16 +58,20 @@ data DeclarationRef

6058 -- |

6159 -- A type operator

6260 --

63− | TypeOpRef Ident

61+ | TypeOpRef (OpName 'TypeOpName)

6462 -- |

6563 -- A value

6664 --

6765 | ValueRef Ident

6866 -- |

67+ -- A value-level operator

68+ --

69+ | ValueOpRef (OpName 'ValueOpName)

70+ -- |

6971 -- A type class

7072 --

7173 | TypeClassRef (ProperName 'ClassName)

72− -- |

74+ -- |

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

7476 --

7577 | TypeInstanceRef Ident

@@ -87,6 +89,7 @@ instance Eq DeclarationRef where

8789 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

8890 (TypeOpRef name) == (TypeOpRef name') = name == name'

8991 (ValueRef name) == (ValueRef name') = name == name'

92+ (ValueOpRef name) == (ValueOpRef name') = name == name'

9093 (TypeClassRef name) == (TypeClassRef name') = name == name'

9194 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

9295 (ModuleRef name) == (ModuleRef name') = name == name'

@@ -94,33 +97,36 @@ instance Eq DeclarationRef where

9497 r == (PositionedDeclarationRef _ _ r') = r == r'

9598 _ == _ = False

9699

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

101+getTypeRef (TypeRef name dctors) = Just (name, dctors)

102+getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r

103+getTypeRef _ = Nothing

104+

105+getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName)

106+getTypeOpRef (TypeOpRef op) = Just op

107+getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r

108+getTypeOpRef _ = Nothing

109+

110+getValueRef :: DeclarationRef -> Maybe Ident

111+getValueRef (ValueRef name) = Just name

112+getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r

113+getValueRef _ = Nothing

114+

115+getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName)

116+getValueOpRef (ValueOpRef op) = Just op

117+getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r

118+getValueOpRef _ = Nothing

119+

120+getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName)

121+getTypeClassRef (TypeClassRef name) = Just name

122+getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r

123+getTypeClassRef _ = Nothing

124+

97125isModuleRef :: DeclarationRef -> Bool

98126isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

99127isModuleRef (ModuleRef _) = True

100128isModuleRef _ = False

101129

102−-- |

103−-- Finds duplicate values in a list of declaration refs. The returned values

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

105−-- list of duplicate data constructors.

106−--

107−findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])

108−findDuplicateRefs refs =

109− let positionless = stripPosInfo `map` refs

110− simplified = simplifyTypeRefs `map` positionless

111− dupeRefs = nub $ simplified \\ nub simplified

112− dupeCtors = concat $ flip mapMaybe positionless $ \case

113− TypeRef _ (Just dctors) ->

114− let dupes = dctors \\ nub dctors

115− in if null dupes then Nothing else Just dupes

116− _ -> Nothing

117− in (dupeRefs, dupeCtors)

118− where

119− stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref

120− stripPosInfo other = other

121− simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing

122− simplifyTypeRefs other = other

123−

124130-- |

125131-- The data type which specifies type of import declaration

126132--

@@ -184,9 +190,9 @@ data Declaration

184190 --

185191 | ExternDataDeclaration (ProperName 'TypeName) Kind

186192 -- |

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

193+ -- A fixity declaration

188194 --

189− | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias))

195+ | FixityDeclaration (Either ValueFixity TypeFixity)

190196 -- |

191197 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

192198 --

@@ -206,30 +212,14 @@ data Declaration

206212 | PositionedDeclaration SourceSpan [Comment] Declaration

207213 deriving (Show, Read)

208214

209−data FixityAlias

210− = AliasValue Ident

211− | AliasConstructor (ProperName 'ConstructorName)

212− | AliasType (ProperName 'TypeName)

215+data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)

213216 deriving (Eq, Ord, Show, Read)

214217

215−foldFixityAlias

216− :: (Ident -> a)

217− -> (ProperName 'ConstructorName -> a)

218− -> (ProperName 'TypeName -> a)

219− -> FixityAlias

220− -> a

221−foldFixityAlias f _ _ (AliasValue name) = f name

222−foldFixityAlias _ g _ (AliasConstructor name) = g name

223−foldFixityAlias _ _ h (AliasType name) = h name

224−

225−getValueAlias :: FixityAlias -> Maybe (Either Ident (ProperName 'ConstructorName))

226−getValueAlias (AliasValue name) = Just $ Left name

227−getValueAlias (AliasConstructor name) = Just $ Right name

228−getValueAlias _ = Nothing

229−

230−getTypeAlias :: FixityAlias -> Maybe (ProperName 'TypeName)

231−getTypeAlias (AliasType name) = Just name

232−getTypeAlias _ = Nothing

218+data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)

219+ deriving (Eq, Ord, Show, Read)

220+

221+pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op))

222+pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op))

233223

234224-- | The members of a type class instance declaration

235225data TypeInstanceBody

@@ -288,6 +278,11 @@ isFixityDecl FixityDeclaration{} = True

288278isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d

289279isFixityDecl _ = False

290280

281+getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity)

282+getFixityDecl (FixityDeclaration fixity) = Just fixity

283+getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d

284+getFixityDecl _ = Nothing

285+

291286-- |

292287-- Test if a declaration is a foreign import

293288--

@@ -376,6 +371,11 @@ data Expr

376371 --

377372 | Var (Qualified Ident)

378373 -- |

374+ -- An operator. This will be desugared into a function during the "operators"

375+ -- phase of desugaring.

376+ --

377+ | Op (Qualified (OpName 'ValueOpName))

378+ -- |

379379 -- Conditional (if-then-else expression)

380380 --

381381 | IfThenElse Expr Expr Expr

@@ -473,4 +473,3 @@ data DoNotationElement

473473

474474$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

475475$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

476−$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias)

src/Language/PureScript/AST/Exported.hs+8−11

@@ -127,18 +127,15 @@ isExported _ TypeInstanceDeclaration{} = True

127127isExported exps (PositionedDeclaration _ _ d) = isExported exps d

128128isExported (Just exps) decl = any (matches decl) exps

129129 where

130− matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

131− matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

132− matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

133− matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

134− matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

135− matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

130+ matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

131+ matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

132+ matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

133+ matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

134+ matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

135+ matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

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

137−

138− matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident'

139− matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident'

140− matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident'

141−

137+ matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'

138+ matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op'

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

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

144141 matches _ _ = False

src/Language/PureScript/Bundle.hs+9−9

@@ -4,15 +4,15 @@

44-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and

55-- performs dead code elimination, filters empty modules,

66-- and generates the final Javascript bundle.

7−module Language.PureScript.Bundle (

8− bundle

9− , ModuleIdentifier(..)

10− , moduleName

11− , ModuleType(..)

12− , ErrorMessage(..)

13− , printErrorMessage

14− , getExportedIdentifiers

15−) where

7+module Language.PureScript.Bundle

8+ ( bundle

9+ , ModuleIdentifier(..)

10+ , moduleName

11+ , ModuleType(..)

12+ , ErrorMessage(..)

13+ , printErrorMessage

14+ , getExportedIdentifiers

15+ ) where

1616

1717import Prelude.Compat

1818

src/Language/PureScript/CodeGen/JS.hs−1

@@ -173,7 +173,6 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

173173 --

174174 accessor :: Ident -> JS -> JS

175175 accessor (Ident prop) = accessorString prop

176− accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)

177176 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

178177

179178 accessorString :: String -> JS -> JS

src/Language/PureScript/CodeGen/JS/Common.hs−1

@@ -29,7 +29,6 @@ identToJs :: Ident -> String

2929identToJs (Ident name)

3030 | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name

3131 | otherwise = concatMap identCharToString name

32−identToJs (Op op) = concatMap identCharToString op

3332identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

3433

3534-- |

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+4−5

@@ -68,13 +68,12 @@ removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

6868removeFromBlock _ js = js

6969

7070isFn :: (String, String) -> JS -> Bool

71−isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName

72−isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName

71+isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =

72+ x == fnName && y == moduleName

73+isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =

74+ x == fnName && y == moduleName

7375isFn _ _ = False

7476

75−isFn' :: [(String, String)] -> JS -> Bool

76−isFn' xs js = any (`isFn` js) xs

77−

7877isDict :: (String, String) -> JS -> Bool

7978isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName

8079isDict _ _ = False

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+98−101

@@ -19,9 +19,7 @@ import Control.Monad.Supply.Class (MonadSupply, freshName)

1919import Data.Maybe (fromMaybe)

2020

2121import Language.PureScript.CodeGen.JS.AST

22−import Language.PureScript.CodeGen.JS.Common

2322import Language.PureScript.CodeGen.JS.Optimizer.Common

24−import Language.PureScript.Names

2523import qualified Language.PureScript.Constants as C

2624

2725-- TODO: Potential bug:

@@ -82,24 +80,24 @@ inlineCommonValues = everywhereOnJS convert

8280 where

8381 convert :: JS -> JS

8482 convert (JSApp ss fn [dict])

85− | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0)

86− | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1)

87− | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False

88− | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True

83+ | isDict' [semiringNumber, semiringInt] dict && isFn fnZero fn = JSNumericLiteral ss (Left 0)

84+ | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1)

85+ | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False

86+ | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True

8987 convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])

90− | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y

91− | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y

92− | isDict' euclideanRingInt dict && isFn' fnDivide fn = intOp ss Divide x y

93− | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y

88+ | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y

89+ | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y

90+ | isDict euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y

91+ | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y

9492 convert other = other

95− fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]

96− fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]

97− fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]

98− fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]

99− fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]

100− fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataEuclideanRing, C.div)]

101− fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]

102− fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

93+ fnZero = (C.dataSemiring, C.zero)

94+ fnOne = (C.dataSemiring, C.one)

95+ fnBottom = (C.dataBounded, C.bottom)

96+ fnTop = (C.dataBounded, C.top)

97+ fnAdd = (C.dataSemiring, C.add)

98+ fnDivide = (C.dataEuclideanRing, C.div)

99+ fnMultiply = (C.dataSemiring, C.mul)

100+ fnSubtract = (C.dataRing, C.sub)

103101 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))

104102

105103inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

@@ -108,7 +106,6 @@ inlineOperator (m, op) f = everywhereOnJS convert

108106 convert :: JS -> JS

109107 convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y

110108 convert other = other

111− isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)

112109 isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'

113110 isOp _ = False

114111

@@ -173,11 +170,11 @@ inlineCommonOperators = applyAll $

173170 ] ++

174171 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

175172 where

176− binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS

173+ binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS

177174 binary dict fns op = everywhereOnJS convert

178175 where

179176 convert :: JS -> JS

180− convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y

177+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y

181178 convert other = other

182179 binary' :: String -> String -> BinaryOperator -> JS -> JS

183180 binary' moduleName opString op = everywhereOnJS convert

@@ -185,11 +182,11 @@ inlineCommonOperators = applyAll $

185182 convert :: JS -> JS

186183 convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y

187184 convert other = other

188− unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS

185+ unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS

189186 unary dicts fns op = everywhereOnJS convert

190187 where

191188 convert :: JS -> JS

192− convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x

189+ convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x

193190 convert other = other

194191 unary' :: String -> String -> UnaryOperator -> JS -> JS

195192 unary' moduleName fnName op = everywhereOnJS convert

@@ -251,118 +248,118 @@ inlineFnComposition = everywhereOnJSTopDownM convert

251248 return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])

252249 convert other = return other

253250 isFnCompose :: JS -> JS -> Bool

254− isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn

251+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn

255252 isFnComposeFlipped :: JS -> JS -> Bool

256− isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn

257− fnCompose :: [(String, String)]

258− fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)]

259− fnComposeFlipped :: [(String, String)]

260− fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)]

253+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn

254+ fnCompose :: (String, String)

255+ fnCompose = (C.controlSemigroupoid, C.compose)

256+ fnComposeFlipped :: (String, String)

257+ fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

261258

262−semiringNumber :: [(String, String)]

263−semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)]

259+semiringNumber :: (String, String)

260+semiringNumber = (C.dataSemiring, C.semiringNumber)

264261

265−semiringInt :: [(String, String)]

266−semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)]

262+semiringInt :: (String, String)

263+semiringInt = (C.dataSemiring, C.semiringInt)

267264

268−ringNumber :: [(String, String)]

269−ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)]

265+ringNumber :: (String, String)

266+ringNumber = (C.dataRing, C.ringNumber)

270267

271−ringInt :: [(String, String)]

272−ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)]

268+ringInt :: (String, String)

269+ringInt = (C.dataRing, C.ringInt)

273270

274−euclideanRingNumber :: [(String, String)]

275−euclideanRingNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataEuclideanRing, C.euclideanRingNumber)]

271+euclideanRingNumber :: (String, String)

272+euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

276273

277−euclideanRingInt :: [(String, String)]

278−euclideanRingInt = [(C.prelude, C.moduloSemiringInt), (C.dataEuclideanRing, C.euclideanRingInt)]

274+euclideanRingInt :: (String, String)

275+euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)

279276

280−eqNumber :: [(String, String)]

281−eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)]

277+eqNumber :: (String, String)

278+eqNumber = (C.dataEq, C.eqNumber)

282279

283−eqInt :: [(String, String)]

284−eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)]

280+eqInt :: (String, String)

281+eqInt = (C.dataEq, C.eqInt)

285282

286−eqString :: [(String, String)]

287−eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)]

283+eqString :: (String, String)

284+eqString = (C.dataEq, C.eqString)

288285

289−eqChar :: [(String, String)]

290−eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)]

286+eqChar :: (String, String)

287+eqChar = (C.dataEq, C.eqChar)

291288

292−eqBoolean :: [(String, String)]

293−eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)]

289+eqBoolean :: (String, String)

290+eqBoolean = (C.dataEq, C.eqBoolean)

294291

295−ordBoolean :: [(String, String)]

296−ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)]

292+ordBoolean :: (String, String)

293+ordBoolean = (C.dataOrd, C.ordBoolean)

297294

298−ordNumber :: [(String, String)]

299−ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)]

295+ordNumber :: (String, String)

296+ordNumber = (C.dataOrd, C.ordNumber)

300297

301−ordInt :: [(String, String)]

302−ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)]

298+ordInt :: (String, String)

299+ordInt = (C.dataOrd, C.ordInt)

303300

304−ordString :: [(String, String)]

305−ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)]

301+ordString :: (String, String)

302+ordString = (C.dataOrd, C.ordString)

306303

307−ordChar :: [(String, String)]

308−ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)]

304+ordChar :: (String, String)

305+ordChar = (C.dataOrd, C.ordChar)

309306

310−semigroupString :: [(String, String)]

311−semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)]

307+semigroupString :: (String, String)

308+semigroupString = (C.dataSemigroup, C.semigroupString)

312309

313−boundedBoolean :: [(String, String)]

314−boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)]

310+boundedBoolean :: (String, String)

311+boundedBoolean = (C.dataBounded, C.boundedBoolean)

315312

316−heytingAlgebraBoolean :: [(String, String)]

317−heytingAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)]

313+heytingAlgebraBoolean :: (String, String)

314+heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

318315

319−semigroupoidFn :: [(String, String)]

320−semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]

316+semigroupoidFn :: (String, String)

317+semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

321318

322−opAdd :: [(String, String)]

323−opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]

319+opAdd :: (String, String)

320+opAdd = (C.dataSemiring, C.add)

324321

325−opMul :: [(String, String)]

326−opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]

322+opMul :: (String, String)

323+opMul = (C.dataSemiring, C.mul)

327324

328−opEq :: [(String, String)]

329−opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]

325+opEq :: (String, String)

326+opEq = (C.dataEq, C.eq)

330327

331−opNotEq :: [(String, String)]

332−opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]

328+opNotEq :: (String, String)

329+opNotEq = (C.dataEq, C.notEq)

333330

334−opLessThan :: [(String, String)]

335−opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]

331+opLessThan :: (String, String)

332+opLessThan = (C.dataOrd, C.lessThan)

336333

337−opLessThanOrEq :: [(String, String)]

338−opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]

334+opLessThanOrEq :: (String, String)

335+opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

339336

340−opGreaterThan :: [(String, String)]

341−opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]

337+opGreaterThan :: (String, String)

338+opGreaterThan = (C.dataOrd, C.greaterThan)

342339

343−opGreaterThanOrEq :: [(String, String)]

344−opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]

340+opGreaterThanOrEq :: (String, String)

341+opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

345342

346−opAppend :: [(String, String)]

347−opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]

343+opAppend :: (String, String)

344+opAppend = (C.dataSemigroup, C.append)

348345

349−opSub :: [(String, String)]

350−opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

346+opSub :: (String, String)

347+opSub = (C.dataRing, C.sub)

351348

352−opNegate :: [(String, String)]

353−opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]

349+opNegate :: (String, String)

350+opNegate = (C.dataRing, C.negate)

354351

355−opDiv :: [(String, String)]

356−opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataEuclideanRing, C.div)]

352+opDiv :: (String, String)

353+opDiv = (C.dataEuclideanRing, C.div)

357354

358−opMod :: [(String, String)]

359−opMod = [(C.prelude, C.mod), (C.dataEuclideanRing, C.mod)]

355+opMod :: (String, String)

356+opMod = (C.dataEuclideanRing, C.mod)

360357

361−opConj :: [(String, String)]

362−opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataHeytingAlgebra, C.conj)]

358+opConj :: (String, String)

359+opConj = (C.dataHeytingAlgebra, C.conj)

363360

364−opDisj :: [(String, String)]

365−opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataHeytingAlgebra, C.disj)]

361+opDisj :: (String, String)

362+opDisj = (C.dataHeytingAlgebra, C.disj)

366363

367−opNot :: [(String, String)]

368−opNot = [(C.prelude, C.not), (C.dataHeytingAlgebra, C.not)]

364+opNot :: (String, String)

365+opNot = (C.dataHeytingAlgebra, C.not)

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+2−2

@@ -63,9 +63,9 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

6363 isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True

6464 isPure _ = False

6565 -- Check if an expression represents the polymorphic >>= function

66− isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]

66+ isBindPoly = isFn (C.controlBind, C.bind)

6767 -- Check if an expression represents the polymorphic pure or return function

68− isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]

68+ isPurePoly = isFn (C.controlApplicative, C.pure')

6969 -- Check if an expression represents a function in the Eff module

7070 isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'

7171 isEffFunc _ _ = False

src/Language/PureScript/CoreFn/Desugar.hs+12−18

@@ -70,12 +70,6 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

7070 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

7171 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

7272 [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]

73− declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasValue name')))) =

74− let meta = getValueMeta (Qualified mn' name')

75− in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' name'))]

76− declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasConstructor name')))) =

77− let meta = Just $ getConstructorMeta (Qualified mn' name')

78− in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' (properToIdent name')))]

7973 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

8074 [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]

8175 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

@@ -204,25 +198,25 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

204198findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]

205199findQualModules decls =

206200 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

207− in f `concatMap` decls

201+ in map (nullAnn,) $ f `concatMap` decls

208202 where

209− fqDecls :: A.Declaration -> [(Ann, ModuleName)]

210− fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

211− fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q

203+ fqDecls :: A.Declaration -> [ModuleName]

204+ fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual' q

205+ fqDecls (A.ValueFixityDeclaration _ q _) = getQual' q

206+ fqDecls (A.TypeFixityDeclaration _ q _) = getQual' q

212207 fqDecls _ = []

213208

214− fqValues :: A.Expr -> [(Ann, ModuleName)]

215− fqValues (A.Var q) = getQual q

216− fqValues (A.Constructor q) = getQual q

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

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

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

217212 fqValues _ = []

218213

219− fqBinders :: A.Binder -> [(Ann, ModuleName)]

220− fqBinders (A.ConstructorBinder q _) = getQual q

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

215+ fqBinders (A.ConstructorBinder q _) = getQual' q

221216 fqBinders _ = []

222217

223− getQual :: Qualified a -> [(Ann, ModuleName)]

224− getQual (Qualified (Just mn) _) = [(nullAnn, mn)]

225− getQual _ = []

218+ getQual' :: Qualified a -> [ModuleName]

219+ getQual' = maybe [] return . getQual

226220

227221-- |

228222-- Desugars import declarations from AST to CoreFn representation.

src/Language/PureScript/Docs/AsMarkdown.hs+13−15

@@ -59,8 +59,6 @@ declAsMarkdown mn decl@Declaration{..} = do

5959 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

6060 spacer

6161

62− for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

63−

6462 for_ declComments tell'

6563

6664 unless (null instances) $ do

@@ -82,19 +80,19 @@ codeToString = outputWith elemAsMarkdown

8280 elemAsMarkdown (Keyword x) = x

8381 elemAsMarkdown Space = " "

8482

85−fixityAsMarkdown :: P.Fixity -> Docs

86−fixityAsMarkdown (P.Fixity associativity precedence) =

87− tell' $ concat [ "_"

88− , associativityStr

89− , " / precedence "

90− , show precedence

91− , "_"

92− ]

93− where

94− associativityStr = case associativity of

95− P.Infixl -> "left-associative"

96− P.Infixr -> "right-associative"

97− P.Infix -> "non-associative"

83+-- fixityAsMarkdown :: P.Fixity -> Docs

84+-- fixityAsMarkdown (P.Fixity associativity precedence) =

85+-- tell' $ concat [ "_"

86+-- , associativityStr

87+-- , " / precedence "

88+-- , show precedence

89+-- , "_"

90+-- ]

91+-- where

92+-- associativityStr = case associativity of

93+-- P.Infixl -> "left-associative"

94+-- P.Infixr -> "right-associative"

95+-- P.Infix -> "non-associative"

9896

9997childToString :: First -> ChildDeclaration -> String

10098childToString f decl@ChildDeclaration{..} =

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

@@ -185,8 +185,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar'

185185 where

186186 desugar' =

187187 traverse P.desugarDoModule

188− >=> P.desugarCasesModule

189− >=> P.desugarTypeDeclarationsModule

188+ >=> traverse P.desugarCasesModule

189+ >=> traverse P.desugarTypeDeclarationsModule

190190 >=> ignoreWarnings . P.desugarImportsWithEnv []

191191

192192 ignoreWarnings = fmap fst . runWriterT

src/Language/PureScript/Docs/Convert/ReExports.hs+61−49

@@ -35,8 +35,7 @@ updateReExports ::

3535 [P.ModuleName] ->

3636 Map P.ModuleName Module ->

3737 Map P.ModuleName Module

38−updateReExports env order modules =

39− execState action modules

38+updateReExports env order = execState action

4039 where

4140 action =

4241 void (traverse go order)

@@ -103,17 +102,18 @@ collectDeclarations ::

103102 P.Exports ->

104103 m [(P.ModuleName, [Declaration])]

105104collectDeclarations imports exports = do

106− valsAndMembers <- collect lookupValueDeclaration impVals expVals

107− typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

108− types <- collect lookupTypeDeclaration impTypes expTypes

109− typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

105+ valsAndMembers <- collect lookupValueDeclaration impVals expVals

106+ valOps <- collect lookupValueOpDeclaration impValOps expValOps

107+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

108+ types <- collect lookupTypeDeclaration impTypes expTypes

109+ typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

110110

111111 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

112112

113113 let filteredTypes = filterDataConstructors expCtors types

114114 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

115115

116− pure (Map.toList (Map.unionsWith (<>) [filteredTypes, typeOps, filteredClasses, vals]))

116+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps]))

117117

118118 where

119119 collect lookup' imps exps = do

@@ -123,6 +123,9 @@ collectDeclarations imports exports = do

123123 expVals = P.exportedValues exports

124124 impVals = concat (Map.elems (P.importedValues imports))

125125

126+ expValOps = P.exportedValueOps exports

127+ impValOps = concat (Map.elems (P.importedValueOps imports))

128+

126129 expTypes = map (first fst) (P.exportedTypes exports)

127130 impTypes = concat (Map.elems (P.importedTypes imports))

128131

@@ -221,6 +224,20 @@ lookupValueDeclaration importedFrom ident = do

221224 thd :: (a, b, c) -> c

222225 thd (_, _, x) = x

223226

227+lookupValueOpDeclaration

228+ :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)

229+ => P.ModuleName

230+ -> P.OpName 'P.ValueOpName

231+ -> m (P.ModuleName, [Declaration])

232+lookupValueOpDeclaration importedFrom op = do

233+ decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom

234+ case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of

235+ [d] ->

236+ pure (importedFrom, [d])

237+ other ->

238+ internalErrorInModule

239+ ("lookupValueOpDeclaration: unexpected result for: " ++ show other)

240+

224241-- |

225242-- Extract a particular type declaration. For data declarations, constructors

226243-- are only included in the output if they are listed in the arguments.

@@ -242,16 +259,15 @@ lookupTypeDeclaration importedFrom ty = do

242259 internalErrorInModule

243260 ("lookupTypeDeclaration: unexpected result: " ++ show other)

244261

245−lookupTypeOpDeclaration ::

246− (MonadState (Map P.ModuleName Module) m,

247− MonadReader P.ModuleName m) =>

248− P.ModuleName ->

249− P.Ident ->

250− m (P.ModuleName, [Declaration])

262+lookupTypeOpDeclaration

263+ :: (MonadState (Map P.ModuleName Module) m,MonadReader P.ModuleName m)

264+ => P.ModuleName

265+ -> P.OpName 'P.TypeOpName

266+ -> m (P.ModuleName, [Declaration])

251267lookupTypeOpDeclaration importedFrom tyOp = do

252268 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

253269 let

254− ds = filter (\d -> declTitle d == ("type " ++ P.showIdent tyOp) && isTypeAlias d) decls

270+ ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls

255271 case ds of

256272 [d] ->

257273 pure (importedFrom, [d])

@@ -259,12 +275,11 @@ lookupTypeOpDeclaration importedFrom tyOp = do

259275 internalErrorInModule

260276 ("lookupTypeOpDeclaration: unexpected result: " ++ show other)

261277

262−lookupTypeClassDeclaration ::

263− (MonadState (Map P.ModuleName Module) m,

264− MonadReader P.ModuleName m) =>

265− P.ModuleName ->

266− P.ProperName 'P.ClassName ->

267− m (P.ModuleName, [Declaration])

278+lookupTypeClassDeclaration

279+ :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)

280+ => P.ModuleName

281+ -> P.ProperName 'P.ClassName

282+ -> m (P.ModuleName, [Declaration])

268283lookupTypeClassDeclaration importedFrom tyClass = do

269284 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

270285 let

@@ -369,10 +384,10 @@ instance Monoid TypeClassEnv where

369384--

370385-- Returns a tuple of (values, type classes).

371386--

372−handleEnv ::

373− (MonadReader P.ModuleName m) =>

374− TypeClassEnv ->

375− m ([Declaration], [Declaration])

387+handleEnv

388+ :: (MonadReader P.ModuleName m)

389+ => TypeClassEnv

390+ -> m ([Declaration], [Declaration])

376391handleEnv TypeClassEnv{..} =

377392 envUnhandledMembers

378393 |> foldM go (envValues, mkMap envTypeClasses)

@@ -400,7 +415,6 @@ handleEnv TypeClassEnv{..} =

400415 , declComments = cdeclComments

401416 , declSourceSpan = cdeclSourceSpan

402417 , declChildren = []

403− , declFixity = Nothing

404418 , declInfo = ValueDeclaration (addConstraint constraint typ)

405419 }

406420 _ ->

@@ -421,10 +435,10 @@ splitMap = foldl go (Map.empty, Map.empty) . Map.toList

421435-- Given a list of exported constructor names, remove any data constructor

422436-- names in the provided Map of declarations which are not in the list.

423437--

424−filterDataConstructors ::

425− [P.ProperName 'P.ConstructorName] ->

426− Map P.ModuleName [Declaration] ->

427− Map P.ModuleName [Declaration]

438+filterDataConstructors

439+ :: [P.ProperName 'P.ConstructorName]

440+ -> Map P.ModuleName [Declaration]

441+ -> Map P.ModuleName [Declaration]

428442filterDataConstructors =

429443 filterExportedChildren isDataConstructor P.runProperName

430444

@@ -433,27 +447,25 @@ filterDataConstructors =

433447-- type class member names in the provided Map of declarations which are not in

434448-- the list.

435449--

436−filterTypeClassMembers ::

437− [P.Ident] ->

438− Map P.ModuleName [Declaration] ->

439− Map P.ModuleName [Declaration]

450+filterTypeClassMembers

451+ :: [P.Ident]

452+ -> Map P.ModuleName [Declaration]

453+ -> Map P.ModuleName [Declaration]

440454filterTypeClassMembers =

441455 filterExportedChildren isTypeClassMember P.showIdent

442456

443−filterExportedChildren ::

444− (Functor f) =>

445− (ChildDeclaration -> Bool) ->

446− (name -> String) ->

447− [name] ->

448− f [Declaration] ->

449− f [Declaration]

450−filterExportedChildren isTargetedKind runName expNames =

451− fmap filterDecls

457+filterExportedChildren

458+ :: (Functor f)

459+ => (ChildDeclaration -> Bool)

460+ -> (name -> String)

461+ -> [name]

462+ -> f [Declaration]

463+ -> f [Declaration]

464+filterExportedChildren isTargetedKind runName expNames = fmap filterDecls

452465 where

453466 filterDecls =

454− map (filterChildren (\c -> not (isTargetedKind c) ||

455− cdeclTitle c `elem` expNames'))

456−

467+ map $ filterChildren $ \c ->

468+ not (isTargetedKind c) || cdeclTitle c `elem` expNames'

457469 expNames' = map runName expNames

458470

459471allDeclarations :: Module -> [Declaration]

@@ -466,10 +478,10 @@ x |> f = f x

466478internalError :: String -> a

467479internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

468480

469−internalErrorInModule ::

470− (MonadReader P.ModuleName m) =>

471− String ->

472− m a

481+internalErrorInModule

482+ :: (MonadReader P.ModuleName m)

483+ => String

484+ -> m a

473485internalErrorInModule msg = do

474486 mn <- ask

475487 internalError

src/Language/PureScript/Docs/Convert/Single.hs+12−43

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

31module Language.PureScript.Docs.Convert.Single

42 ( convertSingleModule

53 , collectBookmarks

@@ -11,8 +9,8 @@ import Control.Category ((>>>))

119import Control.Monad

1210

1311import Data.Either

14−import Data.List (nub, isPrefixOf, isSuffixOf)

15−import Data.Maybe (mapMaybe, isNothing)

12+import Data.List (nub)

13+import Data.Maybe (mapMaybe)

1614

1715import Language.PureScript.Docs.Types

1816import qualified Language.PureScript as P

@@ -30,7 +28,6 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) =

3028 P.exportedDeclarations

3129 >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)

3230 >>> augmentDeclarations

33− >>> map addDefaultFixity

3431

3532-- | The data type for an intermediate stage which we go through during

3633-- converting.

@@ -60,12 +57,8 @@ type IntermediateDeclaration

6057-- since they appear at the top level in the AST, and since they might need to

6158-- appear as children in two places (for example, if a data type defined in a

6259-- module is an instance of a type class also defined in that module).

63−--

64−-- The AugmentFixity constructor allows us to augment operator definitions

65−-- with their associativity and precedence.

6660data DeclarationAugment

6761 = AugmentChild ChildDeclaration

68− | AugmentFixity P.Fixity

6962

7063-- | Augment top-level declarations; the second pass. See the comments under

7164-- the type synonym IntermediateDeclaration for more information.

@@ -79,28 +72,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

7972 then augmentWith a d

8073 else d) ds

8174

82− augmentWith a d =

83− case a of

84− AugmentChild child ->

85− d { declChildren = declChildren d ++ [child] }

86− AugmentFixity fixity ->

87− d { declFixity = Just fixity }

88−

89−-- | Add the default operator fixity for operators which do not have associated

90−-- fixity declarations.

91−--

92−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

93−-- in 0.9.

94−addDefaultFixity :: Declaration -> Declaration

95−addDefaultFixity decl@Declaration{..}

96− | isOp declTitle && isNothing declFixity =

97− decl { declFixity = Just defaultFixity }

98− | otherwise =

99− decl

100− where

101− isOp :: String -> Bool

102− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str

103− defaultFixity = P.Fixity P.Infixl (-1)

75+ augmentWith (AugmentChild child) d =

76+ d { declChildren = declChildren d ++ [child] }

10477

10578getDeclarationTitle :: P.Declaration -> Maybe String

10679getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

@@ -110,8 +83,8 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName nam

11083getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

11184getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

11285getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

113−getDeclarationTitle (P.FixityDeclaration _ name (Just (P.Qualified _ P.AliasType{}))) = Just ("type (" ++ name ++ ")")

114−getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

86+getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)

87+getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)

11588getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

11689getDeclarationTitle _ = Nothing

11790

@@ -122,7 +95,6 @@ mkDeclaration title info =

12295 , declComments = Nothing

12396 , declSourceSpan = Nothing

12497 , declChildren = []

125− , declFixity = Nothing

12698 , declInfo = info

12799 }

128100

@@ -132,7 +104,7 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info

132104convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

133105convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

134106 basicDeclaration title (ValueDeclaration ty)

135−convertDeclaration (P.ValueDeclaration {}) title =

107+convertDeclaration P.ValueDeclaration{} title =

136108 -- If no explicit type declaration was provided, insert a wildcard, so that

137109 -- the actual type will be added during type checking.

138110 basicDeclaration title (ValueDeclaration P.TypeWildcard{})

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

172144

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

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

175−convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =

176− Just (Left ([title], AugmentFixity fixity))

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

178− Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }

147+convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =

148+ Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))

149+convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title =

150+ Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias)))

179151convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

180152 fmap (addComments . addSourceSpan) (convertDeclaration d' title)

181153 where

@@ -191,10 +163,7 @@ convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

191163 Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })

192164 augment)

193165

194− withAugmentChild f (t, a) =

195− case a of

196− AugmentChild d -> (t, AugmentChild (f d))

197− _ -> (t, a)

166+ withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d))

198167convertDeclaration _ _ = Nothing

199168

200169convertComments :: [P.Comment] -> Maybe String

src/Language/PureScript/Docs/Render.hs+19−13

@@ -59,27 +59,33 @@ renderDeclarationWithOptions opts Declaration{..} =

5959 syntax "("

6060 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

6161 <> syntax ")" <> sp <> syntax "<="

62− AliasDeclaration for@(P.Qualified _ alias) (P.Fixity associativity precedence) ->

62+

63+ AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

6364 [ keywordFixity associativity

6465 , syntax $ show precedence

65− , ident $ renderAlias for

66+ , ident $ renderQualAlias for

6667 , keyword "as"

6768 , ident $ adjustAliasName alias declTitle

6869 ]

6970

7071 where

72+ renderType' :: P.Type -> RenderedCode

7173 renderType' = renderTypeWithOptions opts

72− renderAlias (P.Qualified mn alias)

73− | mn == currentModule opts =

74− P.foldFixityAlias P.runIdent P.runProperName (("type " ++) . P.runProperName) alias

75− | otherwise =

76− P.foldFixityAlias

77− (P.showQualified P.runIdent . P.Qualified mn)

78− (P.showQualified P.runProperName . P.Qualified mn)

79− (("type " ++) . P.showQualified P.runProperName . P.Qualified mn)

80− alias

81−

82− adjustAliasName (P.AliasType{}) title = drop 6 (init title)

74+

75+ renderQualAlias :: FixityAlias -> String

76+ renderQualAlias (P.Qualified mn alias)

77+ | mn == currentModule opts = renderAlias id alias

78+ | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias

79+

80+ renderAlias

81+ :: (forall a. (a -> String) -> a -> String)

82+ -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))

83+ -> String

84+ renderAlias f

85+ = either (("type " ++) . f P.runProperName)

86+ $ either (f P.runIdent) (f P.runProperName)

87+

88+ -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)

8389 adjustAliasName _ title = tail (init title)

8490

8591renderChildDeclaration :: ChildDeclaration -> RenderedCode

src/Language/PureScript/Docs/RenderedCode/Render.hs+1−1

@@ -49,7 +49,7 @@ typeLiterals = mkPattern match

4949 match (BinaryNoParensType op l r) =

5050 Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r

5151 match (TypeOp (Qualified mn op)) =

52− Just (ident' (runIdent op) (maybeToContainingModule mn))

52+ Just (ident' (runOpName op) (maybeToContainingModule mn))

5353 match _ =

5454 Nothing

5555

src/Language/PureScript/Docs/Types.hs+12−13

@@ -14,6 +14,7 @@ import Control.Monad (when)

1414import Data.Aeson ((.=))

1515import Data.Aeson.BetterErrors

1616import Data.ByteString.Lazy (ByteString)

17+import Data.Either (isLeft, isRight)

1718import Data.Maybe (mapMaybe)

1819import Data.Text (Text)

1920import Data.Version

@@ -84,7 +85,6 @@ data Declaration = Declaration

8485 , declComments :: Maybe String

8586 , declSourceSpan :: Maybe P.SourceSpan

8687 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9

8888 , declInfo :: DeclarationInfo

8989 }

9090 deriving (Show, Eq, Ord)

@@ -131,9 +131,11 @@ data DeclarationInfo

131131 -- An operator alias declaration, with the member the alias is for and the

132132 -- operator's fixity.

133133 --

134− | AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity

134+ | AliasDeclaration P.Fixity FixityAlias

135135 deriving (Show, Eq, Ord)

136136

137+type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)))

138+

137139declInfoToString :: DeclarationInfo -> String

138140declInfoToString (ValueDeclaration _) = "value"

139141declInfoToString (DataDeclaration _ _) = "data"

@@ -165,14 +167,13 @@ isType Declaration{..} =

165167isValueAlias :: Declaration -> Bool

166168isValueAlias Declaration{..} =

167169 case declInfo of

168− (AliasDeclaration (P.Qualified _ P.AliasConstructor{}) _) -> True

169− (AliasDeclaration (P.Qualified _ P.AliasValue{}) _) -> True

170+ AliasDeclaration _ (P.Qualified _ d) -> isRight d

170171 _ -> False

171172

172173isTypeAlias :: Declaration -> Bool

173174isTypeAlias Declaration{..} =

174175 case declInfo of

175− (AliasDeclaration (P.Qualified _ P.AliasType{}) _) -> True

176+ AliasDeclaration _ (P.Qualified _ d) -> isLeft d

176177 _ -> False

177178

178179-- | Discard any children which do not satisfy the given predicate.

@@ -362,7 +363,6 @@ asDeclaration =

362363 <*> key "comments" (perhaps asString)

363364 <*> key "sourceSpan" (perhaps asSourceSpan)

364365 <*> key "children" (eachInArray asChildDeclaration)

365− <*> key "fixity" (perhaps asFixity)

366366 <*> key "info" asDeclarationInfo

367367

368368asReExport :: Parse PackageError (P.ModuleName, [Declaration])

@@ -383,6 +383,9 @@ asFixity =

383383 P.Fixity <$> key "associativity" asAssociativity

384384 <*> key "precedence" asIntegral

385385

386+asFixityAlias :: Parse PackageError FixityAlias

387+asFixityAlias = fromAesonParser

388+

386389parseAssociativity :: String -> Maybe P.Associativity

387390parseAssociativity str = case str of

388391 "infix" -> Just P.Infix

@@ -411,14 +414,11 @@ asDeclarationInfo = do

411414 TypeClassDeclaration <$> key "arguments" asTypeArguments

412415 <*> key "superclasses" (eachInArray asConstraint)

413416 "alias" ->

414− AliasDeclaration <$> key "for" asAliasFor

415− <*> key "fixity" asFixity

417+ AliasDeclaration <$> key "fixity" asFixity

418+ <*> key "alias" asFixityAlias

416419 other ->

417420 throwCustomError (InvalidDeclarationType other)

418421

419−asAliasFor :: Parse e (P.Qualified P.FixityAlias)

420−asAliasFor = fromAesonParser

421−

422422asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

423423asTypeArguments = eachInArray asTypeArgument

424424 where

@@ -537,7 +537,6 @@ instance A.ToJSON Declaration where

537537 , "comments" .= declComments

538538 , "sourceSpan" .= declSourceSpan

539539 , "children" .= declChildren

540− , "fixity" .= declFixity

541540 , "info" .= declInfo

542541 ]

543542

@@ -558,7 +557,7 @@ instance A.ToJSON DeclarationInfo where

558557 ExternDataDeclaration kind -> ["kind" .= kind]

559558 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

560559 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

561− AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]

560+ AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

562561

563562instance A.ToJSON ChildDeclarationInfo where

564563 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

src/Language/PureScript/Errors.hs+61−114

@@ -48,32 +48,19 @@ data SimpleErrorMessage

4848 | CannotWriteFile FilePath

4949 | InfiniteType Type

5050 | InfiniteKind Kind

51− | MultipleFixities Ident

51+ | MultipleValueOpFixities (OpName 'ValueOpName)

52+ | MultipleTypeOpFixities (OpName 'TypeOpName)

5253 | OrphanTypeDeclaration Ident

53− | OrphanFixityDeclaration String

5454 | RedefinedModule ModuleName [SourceSpan]

5555 | RedefinedIdent Ident

5656 | OverlappingNamesInLet

57− | UnknownModule ModuleName

58− | UnknownType (Qualified (ProperName 'TypeName))

59− | UnknownTypeOp (Qualified Ident)

60− | UnknownTypeClass (Qualified (ProperName 'ClassName))

61− | UnknownValue (Qualified Ident)

62− | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

63− | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

64− | UnknownImportType ModuleName (ProperName 'TypeName)

65− | UnknownExportType (ProperName 'TypeName)

66− | UnknownImportTypeOp ModuleName Ident

67− | UnknownExportTypeOp Ident

68− | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

69− | UnknownExportTypeClass (ProperName 'ClassName)

70− | UnknownImportValue ModuleName Ident

71− | UnknownExportValue Ident

72− | UnknownExportModule ModuleName

57+ | UnknownName (Qualified Name)

58+ | UnknownImport ModuleName Name

7359 | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

60+ | UnknownExport Name

7461 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

75− | ScopeConflict String [ModuleName]

76− | ScopeShadowing String (Maybe ModuleName) [ModuleName]

62+ | ScopeConflict Name [ModuleName]

63+ | ScopeShadowing Name (Maybe ModuleName) [ModuleName]

7764 | ConflictingTypeDecls (ProperName 'TypeName)

7865 | ConflictingCtorDecls (ProperName 'ConstructorName)

7966 | TypeConflictsWithClass (ProperName 'TypeName)

@@ -83,7 +70,8 @@ data SimpleErrorMessage

8370 | DuplicateModuleName ModuleName

8471 | DuplicateClassExport (ProperName 'ClassName)

8572 | DuplicateValueExport Ident

86− | DuplicateTypeOpExport Ident

73+ | DuplicateValueOpExport (OpName 'ValueOpName)

74+ | DuplicateTypeOpExport (OpName 'TypeOpName)

8775 | DuplicateTypeArgument String

8876 | InvalidDoBind

8977 | InvalidDoLet

@@ -128,18 +116,16 @@ data SimpleErrorMessage

128116 | MissingTypeDeclaration Ident Type

129117 | OverlappingPattern [[Binder]] Bool

130118 | IncompleteExhaustivityCheck

131− | ClassOperator (ProperName 'ClassName) Ident

132119 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

133120 | ImportHidingModule ModuleName

134121 | UnusedImport ModuleName

135122 | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

136123 | UnusedDctorImport (ProperName 'TypeName)

137124 | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

138− | DeprecatedOperatorDecl String

139125 | DuplicateSelectiveImport ModuleName

140126 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

141− | DuplicateImportRef String

142− | DuplicateExportRef String

127+ | DuplicateImportRef Name

128+ | DuplicateExportRef Name

143129 | IntOutOfRange Integer String Integer Integer

144130 | RedundantEmptyHidingImport ModuleName

145131 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

@@ -147,7 +133,7 @@ data SimpleErrorMessage

147133 | HidingImport ModuleName [DeclarationRef]

148134 | CaseBinderLengthDiffers Int [Binder]

149135 | IncorrectAnonymousArgument

150− | InvalidOperatorInBinder Ident Ident

136+ | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

151137 | DeprecatedRequirePath

152138 | CannotGeneralizeRecursiveFunction Ident Type

153139 deriving (Show)

@@ -232,29 +218,16 @@ errorCode em = case unwrapErrorMessage em of

232218 CannotWriteFile{} -> "CannotWriteFile"

233219 InfiniteType{} -> "InfiniteType"

234220 InfiniteKind{} -> "InfiniteKind"

235− MultipleFixities{} -> "MultipleFixities"

221+ MultipleValueOpFixities{} -> "MultipleValueOpFixities"

222+ MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"

236223 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

237− OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

238224 RedefinedModule{} -> "RedefinedModule"

239225 RedefinedIdent{} -> "RedefinedIdent"

240226 OverlappingNamesInLet -> "OverlappingNamesInLet"

241− UnknownModule{} -> "UnknownModule"

242− UnknownType{} -> "UnknownType"

243− UnknownTypeOp{} -> "UnknownTypeOp"

244− UnknownTypeClass{} -> "UnknownTypeClass"

245− UnknownValue{} -> "UnknownValue"

246− UnknownDataConstructor{} -> "UnknownDataConstructor"

247− UnknownTypeConstructor{} -> "UnknownTypeConstructor"

248− UnknownImportType{} -> "UnknownImportType"

249− UnknownImportTypeOp{} -> "UnknownImportTypeOp"

250− UnknownExportType{} -> "UnknownExportType"

251− UnknownExportTypeOp{} -> "UnknownExportTypeOp"

252− UnknownImportTypeClass{} -> "UnknownImportTypeClass"

253− UnknownExportTypeClass{} -> "UnknownExportTypeClass"

254− UnknownImportValue{} -> "UnknownImportValue"

255− UnknownExportValue{} -> "UnknownExportValue"

256− UnknownExportModule{} -> "UnknownExportModule"

227+ UnknownName{} -> "UnknownName"

228+ UnknownImport{} -> "UnknownImport"

257229 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

230+ UnknownExport{} -> "UnknownExport"

258231 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

259232 ScopeConflict{} -> "ScopeConflict"

260233 ScopeShadowing{} -> "ScopeShadowing"

@@ -267,6 +240,7 @@ errorCode em = case unwrapErrorMessage em of

267240 DuplicateModuleName{} -> "DuplicateModuleName"

268241 DuplicateClassExport{} -> "DuplicateClassExport"

269242 DuplicateValueExport{} -> "DuplicateValueExport"

243+ DuplicateValueOpExport{} -> "DuplicateValueOpExport"

270244 DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"

271245 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

272246 InvalidDoBind -> "InvalidDoBind"

@@ -312,14 +286,12 @@ errorCode em = case unwrapErrorMessage em of

312286 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

313287 OverlappingPattern{} -> "OverlappingPattern"

314288 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

315− ClassOperator{} -> "ClassOperator"

316289 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

317290 ImportHidingModule{} -> "ImportHidingModule"

318291 UnusedImport{} -> "UnusedImport"

319292 UnusedExplicitImport{} -> "UnusedExplicitImport"

320293 UnusedDctorImport{} -> "UnusedDctorImport"

321294 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

322− DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

323295 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

324296 DuplicateImport{} -> "DuplicateImport"

325297 DuplicateImportRef{} -> "DuplicateImportRef"

@@ -541,7 +513,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

541513 paras $ [ line "Unable to parse foreign module:"

542514 , indent . line $ path

543515 ] ++

544− (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)))

516+ map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))

545517 renderSimpleErrorMessage (ErrorParsingModule err) =

546518 paras [ line "Unable to parse module: "

547519 , prettyPrintParseError err

@@ -586,70 +558,36 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

586558 paras [ line "An infinite kind was inferred for a type: "

587559 , indent $ line $ prettyPrintKind ki

588560 ]

589− renderSimpleErrorMessage (MultipleFixities name) =

590− line $ "There are multiple fixity/precedence declarations for " ++ showIdent name

561+ renderSimpleErrorMessage (MultipleValueOpFixities op) =

562+ line $ "There are multiple fixity/precedence declarations for operator " ++ showOp op

563+ renderSimpleErrorMessage (MultipleTypeOpFixities op) =

564+ line $ "There are multiple fixity/precedence declarations for type operator " ++ showOp op

591565 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

592566 line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."

593− renderSimpleErrorMessage (OrphanFixityDeclaration op) =

594− line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition."

595567 renderSimpleErrorMessage (RedefinedModule name filenames) =

596568 paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")

597569 , indent . paras $ map (line . displaySourceSpan) filenames

598570 ]

599571 renderSimpleErrorMessage (RedefinedIdent name) =

600572 line $ "The value " ++ showIdent name ++ " has been defined multiple times"

601− renderSimpleErrorMessage (UnknownModule mn) =

602− line $ "Unknown module " ++ runModuleName mn

603− renderSimpleErrorMessage (UnknownType name) =

604− line $ "Unknown type " ++ showQualified runProperName name

605− renderSimpleErrorMessage (UnknownTypeOp name) =

606− line $ "Unknown type operator " ++ showQualified showIdent name

607− renderSimpleErrorMessage (UnknownTypeClass name) =

608− line $ "Unknown type class " ++ showQualified runProperName name

609− renderSimpleErrorMessage (UnknownValue name) =

610− line $ "Unknown value " ++ showQualified showIdent name

611− renderSimpleErrorMessage (UnknownTypeConstructor name) =

612− line $ "Unknown type constructor " ++ showQualified runProperName name

613− renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

614− line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

615− renderSimpleErrorMessage (UnknownImportType mn name) =

616− paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn

573+ renderSimpleErrorMessage (UnknownName name) =

574+ line $ "Unknown " ++ printName name

575+ renderSimpleErrorMessage (UnknownImport mn name) =

576+ paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn

617577 , line "It either does not exist or the module does not export it."

618578 ]

619− renderSimpleErrorMessage (UnknownExportType name) =

620− line $ "Cannot export unknown type " ++ runProperName name

621− renderSimpleErrorMessage (UnknownImportTypeOp mn name) =

622− paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn

623− , line "It either does not exist or the module does not export it."

624− ]

625− renderSimpleErrorMessage (UnknownExportTypeOp name) =

626− line $ "Cannot export unknown type operator " ++ showIdent name

627− renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

628− paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn

629− , line "It either does not exist or the module does not export it."

630− ]

631− renderSimpleErrorMessage (UnknownExportTypeClass name) =

632− line $ "Cannot export unknown type class " ++ runProperName name

633− renderSimpleErrorMessage (UnknownImportValue mn name) =

634− paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn

635− , line "It either does not exist or the module does not export it."

636− ]

637− renderSimpleErrorMessage (UnknownExportValue name) =

638− line $ "Cannot export unknown value " ++ showIdent name

639− renderSimpleErrorMessage (UnknownExportModule name) =

640− paras [ line $ "Cannot export unknown module " ++ runModuleName name

641− , line "It either does not exist or has not been imported by the current module."

642− ]

643− renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

579+ renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) =

644580 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

581+ renderSimpleErrorMessage (UnknownExport name) =

582+ line $ "Cannot export unknown " ++ printName (Qualified Nothing name)

645583 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

646584 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

647585 renderSimpleErrorMessage (ScopeConflict nm ms) =

648− paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"

586+ paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"

649587 , indent $ paras $ map (line . runModuleName) ms

650588 ]

651589 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =

652− paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:"

590+ paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"

653591 , indent $ paras $ map (line . ("import " ++) . runModuleName) ms

654592 , line $ "These will be ignored and the " ++ case exmn of

655593 Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."

@@ -673,8 +611,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

673611 line $ "Duplicate export declaration for type class " ++ runProperName nm

674612 renderSimpleErrorMessage (DuplicateValueExport nm) =

675613 line $ "Duplicate export declaration for value " ++ showIdent nm

676− renderSimpleErrorMessage (DuplicateTypeOpExport nm) =

677− line $ "Duplicate export declaration for type operator " ++ showIdent nm

614+ renderSimpleErrorMessage (DuplicateValueOpExport op) =

615+ line $ "Duplicate export declaration for operator " ++ showOp op

616+ renderSimpleErrorMessage (DuplicateTypeOpExport op) =

617+ line $ "Duplicate export declaration for type operator " ++ showOp op

678618 renderSimpleErrorMessage (CycleInDeclaration nm) =

679619 line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."

680620 renderSimpleErrorMessage (CycleInModules mns) =

@@ -867,11 +807,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

867807 line $ "Type variable '" ++ tv ++ "' was shadowed."

868808 renderSimpleErrorMessage (UnusedTypeVar tv) =

869809 line $ "Type variable '" ++ tv ++ "' was declared but not used."

870− renderSimpleErrorMessage (ClassOperator className opName) =

871− paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

872− , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

873− , indent . line $ showIdent opName ++ " = someMember"

874− ]

875810 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

876811 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

877812 renderSimpleErrorMessage (ImportHidingModule name) =

@@ -917,24 +852,17 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

917852 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

918853 , indent $ paras $ map (line .runProperName) names ]

919854

920− renderSimpleErrorMessage (DeprecatedOperatorDecl name) =

921− paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

922− , line "Operator aliases are declared by using a fixity declaration, for example:"

923− , indent $ line $ "infixl 9 someFunction as " ++ name

924− , line "Support for value-declared operators will be removed in PureScript 0.9."

925− ]

926−

927855 renderSimpleErrorMessage (DuplicateSelectiveImport name) =

928856 line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists"

929857

930858 renderSimpleErrorMessage (DuplicateImport name imp qual) =

931859 line $ "Duplicate import of " ++ prettyPrintImport name imp qual

932860

933− renderSimpleErrorMessage (DuplicateImportRef ref) =

934− line $ "Import list contains multiple references to " ++ ref

861+ renderSimpleErrorMessage (DuplicateImportRef name) =

862+ line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)

935863

936− renderSimpleErrorMessage (DuplicateExportRef ref) =

937− line $ "Export list contains multiple references to " ++ ref

864+ renderSimpleErrorMessage (DuplicateExportRef name) =

865+ line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)

938866

939867 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

940868 paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."

@@ -969,7 +897,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

969897 line "An anonymous function argument appears in an invalid context."

970898

971899 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

972− paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."

900+ paras [ line $ "Operator " ++ showQualified showOp op ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."

973901 , line "Only aliases for data constructors may be used in patterns."

974902 ]

975903

@@ -1099,6 +1027,24 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

10991027 , detail

11001028 ]

11011029

1030+ printName :: Qualified Name -> String

1031+ printName (Qualified mn (IdentName name)) =

1032+ "value " ++ showQualified showIdent (Qualified mn name)

1033+ printName (Qualified mn (ValOpName op)) =

1034+ "operator " ++ showQualified showOp (Qualified mn op)

1035+ printName (Qualified mn (TyName name)) =

1036+ "type " ++ showQualified runProperName (Qualified mn name)

1037+ printName (Qualified mn (TyOpName op)) =

1038+ "type operator " ++ showQualified showOp (Qualified mn op)

1039+ printName (Qualified mn (DctorName name)) =

1040+ "data constructor " ++ showQualified runProperName (Qualified mn name)

1041+ printName (Qualified mn (TyClassName name)) =

1042+ "type class " ++ showQualified runProperName (Qualified mn name)

1043+ printName (Qualified Nothing (ModName name)) =

1044+ "module " ++ runModuleName name

1045+ printName (Qualified _ ModName{}) =

1046+ internalError "qualified ModName in printName"

1047+

11021048 valueDepth :: Int

11031049 valueDepth | full = 1000

11041050 | otherwise = 3

@@ -1179,8 +1125,9 @@ prettyPrintRef :: DeclarationRef -> String

11791125prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

11801126prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

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

1182−prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident

1128+prettyPrintRef (TypeOpRef op) = "type " ++ showOp op

11831129prettyPrintRef (ValueRef ident) = showIdent ident

1130+prettyPrintRef (ValueOpRef op) = showOp op

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

11851132prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

src/Language/PureScript/Externs.hs+31−10

@@ -8,6 +8,7 @@ module Language.PureScript.Externs

88 ( ExternsFile(..)

99 , ExternsImport(..)

1010 , ExternsFixity(..)

11+ , ExternsTypeFixity(..)

1112 , ExternsDeclaration(..)

1213 , moduleToExternsFile

1314 , applyExternsFileToEnvironment

@@ -45,6 +46,8 @@ data ExternsFile = ExternsFile

4546 , efImports :: [ExternsImport]

4647 -- | List of operators and their fixities

4748 , efFixities :: [ExternsFixity]

49+ -- | List of type operators and their fixities

50+ , efTypeFixities :: [ExternsTypeFixity]

4851 -- | List of type and value declaration

4952 , efDeclarations :: [ExternsDeclaration]

5053 } deriving (Show, Read)

@@ -68,9 +71,22 @@ data ExternsFixity = ExternsFixity

6871 -- | The precedence level of the operator

6972 , efPrecedence :: Precedence

7073 -- | The operator symbol

71− , efOperator :: String

74+ , efOperator :: OpName 'ValueOpName

7275 -- | The value the operator is an alias for

73− , efAlias :: Maybe (Qualified FixityAlias)

76+ , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))

77+ } deriving (Show, Read)

78+

79+-- | A type fixity declaration in an externs file

80+data ExternsTypeFixity = ExternsTypeFixity

81+ {

82+ -- | The associativity of the operator

83+ efTypeAssociativity :: Associativity

84+ -- | The precedence level of the operator

85+ , efTypePrecedence :: Precedence

86+ -- | The operator symbol

87+ , efTypeOperator :: OpName 'TypeOpName

88+ -- | The value the operator is an alias for

89+ , efTypeAlias :: Qualified (ProperName 'TypeName)

7490 } deriving (Show, Read)

7591

7692-- | A type or value declaration appearing in an externs file

@@ -147,20 +163,24 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

147163 efExports = exps

148164 efImports = mapMaybe importDecl ds

149165 efFixities = mapMaybe fixityDecl ds

166+ efTypeFixities = mapMaybe typeFixityDecl ds

150167 efDeclarations = concatMap toExternsDeclaration efExports

151168

152169 fixityDecl :: Declaration -> Maybe ExternsFixity

153− fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =

154− fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

155− where

156− exportsOp :: DeclarationRef -> Bool

157− exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

158− exportsOp (ValueRef ident') = ident' == Op op

159− exportsOp (TypeOpRef ident') = ident' == Op op

160− exportsOp _ = False

170+ fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) =

171+ fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps)

161172 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

162173 fixityDecl _ = Nothing

163174

175+ typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity

176+ typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) =

177+ fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps)

178+ typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d

179+ typeFixityDecl _ = Nothing

180+

181+ findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool

182+ findOp get op = maybe False (== op) . get

183+

164184 importDecl :: Declaration -> Maybe ExternsImport

165185 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)

166186 importDecl (PositionedDeclaration _ _ d) = importDecl d

@@ -201,5 +221,6 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

201221

202222$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)

203223$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)

224+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity)

204225$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)

205226$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)

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

@@ -58,13 +58,13 @@ identToText :: P.Ident -> Text

5858identToText = T.pack . P.runIdent

5959

6060convertExterns :: PE.ExternsFile -> Module

61−convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls)

61+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls)

6262 where

6363 moduleName = moduleNameToText (PE.efModuleName ef)

6464 importDecls = convertImport <$> PE.efImports ef

6565 exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef)

66− -- Ignoring operator fixities for now since we're not using them

67− -- operatorDecls = convertOperator <$> PE.efFixities ef

66+ operatorDecls = convertOperator <$> PE.efFixities ef

67+ tyOperatorDecls = convertTypeOperator <$> PE.efTypeFixities ef

6868 otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)

6969

7070 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)

@@ -102,6 +102,14 @@ convertDecl PE.EDValue{..} = Just $

102102convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName

103103convertDecl PE.EDInstance{} = Nothing

104104

105+convertOperator :: PE.ExternsFixity -> ExternDecl

106+convertOperator PE.ExternsFixity{..} =

107+ FixityDeclaration (Left efOperator)

108+

109+convertTypeOperator :: PE.ExternsTypeFixity -> ExternDecl

110+convertTypeOperator PE.ExternsTypeFixity{..} =

111+ FixityDeclaration (Right efTypeOperator)

112+

105113unwrapPositioned :: P.Declaration -> P.Declaration

106114unwrapPositioned (P.PositionedDeclaration _ _ x) = x

107115unwrapPositioned x = x

src/Language/PureScript/Ide/Imports.hs+9−6

@@ -209,15 +209,18 @@ addExplicitImport' decl moduleName imports =

209209 then imports

210210 else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports

211211 where

212− refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n

212+ refFromDeclaration (TypeClassDeclaration n) =

213+ P.TypeClassRef n

213214 refFromDeclaration (DataConstructor n tn _) =

214215 P.TypeRef tn (Just [P.ProperName (T.unpack n)])

215− refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just [])

216+ refFromDeclaration (TypeDeclaration n _) =

217+ P.TypeRef n (Just [])

218+ refFromDeclaration (FixityDeclaration (Left op)) =

219+ P.ValueOpRef op

220+ refFromDeclaration (FixityDeclaration (Right op)) =

221+ P.TypeOpRef op

216222 refFromDeclaration d =

217− let

218− ident = T.unpack (identifierFromExternDecl d)

219− in

220− P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident)

223+ P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d)

221224

222225 -- | Adds a declaration to an import:

223226 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

src/Language/PureScript/Ide/Types.hs+1

@@ -61,6 +61,7 @@ data ExternDecl

6161 P.Type -- The "type"

6262 -- | An exported module

6363 | TypeClassDeclaration (P.ProperName 'P.ClassName)

64+ | FixityDeclaration (Either (P.OpName 'P.ValueOpName) (P.OpName 'P.TypeOpName))

6465 | Export ModuleIdent -- The exported Modules name

6566 deriving (Show,Eq,Ord)

6667

src/Language/PureScript/Ide/Util.hs+5

@@ -31,6 +31,9 @@ runProperNameT = T.pack . P.runProperName

3131runIdentT :: P.Ident -> Text

3232runIdentT = T.pack . P.runIdent

3333

34+runOpNameT :: P.OpName a -> Text

35+runOpNameT = T.pack . P.runOpName

36+

3437prettyTypeT :: P.Type -> Text

3538prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType

3639

@@ -41,6 +44,8 @@ identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name

4144identifierFromExternDecl (DataConstructor name _ _) = name

4245identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name

4346identifierFromExternDecl (ModuleDecl name _) = name

47+identifierFromExternDecl (FixityDeclaration (Left op)) = runOpNameT op

48+identifierFromExternDecl (FixityDeclaration (Right op)) = runOpNameT op

4449identifierFromExternDecl Dependency{} = "~Dependency~"

4550identifierFromExternDecl Export{} = "~Export~"

4651

src/Language/PureScript/Linter.hs+1−11

@@ -40,7 +40,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

4040 lintDeclaration :: Declaration -> m ()

4141 lintDeclaration = tell . f

4242 where

43− (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo

43+ (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo

4444

4545 f :: Declaration -> MultipleErrors

4646 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

@@ -48,16 +48,6 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

4848 f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

4949 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

5050

51− stepD :: S.Set Ident -> Declaration -> MultipleErrors

52− stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)

53− stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls

54− where

55− go :: Declaration -> MultipleErrors

56− go (PositionedDeclaration _ _ d') = go d'

57− go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)

58− go _ = mempty

59− stepD _ _ = mempty

60−

6151 stepE :: S.Set Ident -> Expr -> MultipleErrors

6252 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

6353 stepE s (Let ds' _) = foldMap go ds'

src/Language/PureScript/Linter/Imports.hs+164−133

@@ -6,52 +6,32 @@ module Language.PureScript.Linter.Imports

77import Prelude.Compat

9−import Control.Monad (unless, when)

10−import Control.Monad.Error.Class (MonadError(..))

9+import Control.Monad (join, unless, when, foldM, (<=<))

1110import Control.Monad.Writer.Class

1211

13−import Data.Foldable (forM_)

14−import Data.List ((\\), find, intersect, nub)

15−import Data.Maybe (mapMaybe)

12+import Data.Function (on)

13+import Data.Foldable (for_)

14+import Data.List (find, intersect, nub, groupBy, sortBy, (\\))

15+import Data.Maybe (mapMaybe, fromMaybe)

1616import Data.Monoid (Sum(..))

17+import Data.Traversable (forM)

1718import qualified Data.Map as M

1819

1920import Language.PureScript.AST.Declarations

2021import Language.PureScript.AST.SourcePos

2122import Language.PureScript.Crash

2223import Language.PureScript.Errors

23−import Language.PureScript.Names as P

24+import Language.PureScript.Names

25+import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)

2426import Language.PureScript.Sugar.Names.Env

2527import Language.PureScript.Sugar.Names.Imports

2628import qualified Language.PureScript.Constants as C

2729

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

29−data Name

30− = IdentName (Qualified Ident)

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

32− | TyOpName (Qualified Ident)

33− | DctorName (Qualified (ProperName 'ConstructorName))

34− | TyClassName (Qualified (ProperName 'ClassName))

35− deriving (Eq, Show)

36−

37−getIdentName :: Maybe ModuleName -> Name -> Maybe Ident

38−getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

39−getIdentName _ _ = Nothing

40−

41−getTypeOpName :: Maybe ModuleName -> Name -> Maybe Ident

42−getTypeOpName q (TyOpName (Qualified q' name)) | q == q' = Just name

43−getTypeOpName _ _ = Nothing

44−

45−getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

46−getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

47−getTypeName _ _ = Nothing

48−

49−getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)

50−getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name

51−getClassName _ _ = Nothing

52−

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

54−type UsedImports = M.Map ModuleName [Name]

30+-- |

31+-- Map of module name to list of imported names from that module which have

32+-- been used.

33+--

34+type UsedImports = M.Map ModuleName [Qualified Name]

5535

5636-- |

5737-- Find and warn on:

@@ -69,46 +49,80 @@ type UsedImports = M.Map ModuleName [Name]

6949--

7050lintImports

7151 :: forall m

72− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

52+ . MonadWriter MultipleErrors m

7353 => Module

7454 -> Env

7555 -> UsedImports

7656 -> m ()

77−lintImports (Module _ _ mn mdecls mexports) env usedImps = do

57+lintImports (Module _ _ _ _ Nothing) _ _ = return ()

58+lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

59+

60+ -- TODO: this needs some work to be easier to understand

7861

79− let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)

62+ let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env)

8063 usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

8164 numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls

8265 allowImplicit = numOpenImports == 1

66+ imports = M.toAscList (findImports mdecls)

8367

84− imps <- M.toAscList <$> findImports mdecls

85−

86− forM_ imps $ \(mni, decls) ->

87− unless (isPrim mni) $ do

88− forM_ decls $ \(ss, declType, qualifierName) ->

89− censor (onErrorMessages $ addModuleLocError ss) $ do

68+ for_ imports $ \(mni, decls) ->

69+ unless (isPrim mni) $

70+ for_ decls $ \(ss', declType, qualifierName) ->

71+ maybe id warnWithPosition ss' $ do

9072 let names = nub $ M.findWithDefault [] mni usedImps'

9173 lintImportDecl env mni qualifierName names declType allowImplicit

9274

93− forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do

75+ for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do

9476 let mnis = nub $ map (\(_, _, mni) -> mni) entries

9577 unless (length mnis == 1) $ do

9678 let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

97− forM_ implicits $ \(ss, _, mni) ->

98− censor (onErrorMessages $ addModuleLocError ss) $ do

79+ for_ implicits $ \(ss', _, mni) ->

80+ maybe id warnWithPosition ss' $ do

9981 let names = nub $ M.findWithDefault [] mni usedImps'

10082 usedRefs = findUsedRefs env mni (Just mnq) names

10183 unless (null usedRefs) $

10284 tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

10385

104− return ()

86+ for_ imports $ \(mnq, imps) -> do

87+

88+ warned <- foldM (checkDuplicateImports mnq) [] (selfCartesianSubset imps)

89+

90+ let unwarned = imps \\ warned

91+ duplicates

92+ = join

93+ . map tail

94+ . filter ((> 1) . length)

95+ . groupBy ((==) `on` defQual)

96+ . sortBy (compare `on` defQual)

97+ $ unwarned

98+

99+ for_ duplicates $ \(pos, _, _) ->

100+ maybe id warnWithPosition pos $

101+ tell $ errorMessage $ DuplicateSelectiveImport mnq

102+

103+ for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> do

104+ warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of

105+ Explicit refs -> refs

106+ Hiding refs -> refs

107+ _ -> []

108+ for_ (M.lookup mn env) $ \(_, imported, _) ->

109+ checkEmptyImport mnq imported typ

105110

106111 where

107112

113+ defQual :: ImportDef -> Maybe ModuleName

114+ defQual (_, _, q) = q

115+

116+ selfCartesianSubset :: [a] -> [(a, a)]

117+ selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs

118+ selfCartesianSubset [] = []

119+

108120 countOpenImports :: Declaration -> Int

109− countOpenImports (ImportDeclaration mn' Implicit Nothing) | not (isPrim mn') = 1

110− countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) | not (isPrim mn') = 1

111121 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

122+ countOpenImports (ImportDeclaration mn' Implicit Nothing)

123+ | not (isPrim mn') = 1

124+ countOpenImports (ImportDeclaration mn' (Hiding _) Nothing)

125+ | not (isPrim mn') = 1

112126 countOpenImports _ = 0

113127

114128 -- Checks whether a module is the Prim module - used to suppress any checks

@@ -125,15 +139,15 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

125139 byQual = foldr goImp M.empty

126140 where

127141 goImp (mni, xs) acc = foldr (goDecl mni) acc xs

128− goDecl mni (ss, declType, Just qmn) acc =

129− let entry = (ss, declType, mni)

142+ goDecl mni (ss', declType, Just qmn) acc =

143+ let entry = (ss', declType, mni)

130144 in M.alter (Just . maybe [entry] (entry :)) qmn acc

131145 goDecl _ _ acc = acc

132146

133147 -- The list of modules that are being re-exported by the current module. Any

134148 -- module that appears in this list is always considered to be used.

135149 exportedModules :: [ModuleName]

136− exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports

150+ exportedModules = nub $ mapMaybe extractModule mexports

137151 where

138152 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

139153 extractModule (ModuleRef mne) = Just mne

@@ -150,46 +164,44 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

150164 values = extractByQual mne (importedValues scope) IdentName

151165 in foldr go used (classes ++ types ++ dctors ++ values)

152166 where

153− go :: (ModuleName, Name) -> UsedImports -> UsedImports

167+ go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports

154168 go (q, name) = M.alter (Just . maybe [name] (name :)) q

155169

156170 extractByQual

157171 :: (Eq a)

158172 => ModuleName

159173 -> M.Map (Qualified a) [ImportRecord a]

160− -> (Qualified a -> Name)

161− -> [(ModuleName, Name)]

174+ -> (a -> Name)

175+ -> [(ModuleName, Qualified Name)]

162176 extractByQual k m toName = mapMaybe go (M.toList m)

163177 where

164178 go (q@(Qualified mnq _), is)

165179 | isUnqualified q =

166180 case find (isQualifiedWith k) (map importName is) of

167− Just (Qualified _ name) -> Just (k, toName $ Qualified mnq name)

181+ Just (Qualified _ name) -> Just (k, Qualified mnq (toName name))

168182 _ -> Nothing

169183 | isQualifiedWith k q =

170− case importName (head is) of

171− Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)

172− _ -> internalError "unqualified name in extractByQual"

184+ case importName (head is) of

185+ Qualified (Just mn') name -> Just (mn', Qualified mnq (toName name))

186+ _ -> internalError "unqualified name in extractByQual"

173187 go _ = Nothing

174188

175189lintImportDecl

176190 :: forall m

177− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

191+ . MonadWriter MultipleErrors m

178192 => Env

179193 -> ModuleName

180194 -> Maybe ModuleName

181− -> [Name]

195+ -> [Qualified Name]

182196 -> ImportDeclarationType

183197 -> Bool

184− -> m ()

198+ -> m Bool

185199lintImportDecl env mni qualifierName names declType allowImplicit =

186200 case declType of

187201 Implicit -> case qualifierName of

188− Nothing -> unless allowImplicit (checkImplicit ImplicitImport)

189− Just q ->

190− let usedModuleNames = mapMaybe extractQualName names

191− in unless (q `elem` usedModuleNames) unused

192− Hiding _ -> unless allowImplicit (checkImplicit HidingImport)

202+ Nothing -> unless' allowImplicit (checkImplicit ImplicitImport)

203+ Just q -> unless' (q `elem` mapMaybe getQual names) unused

204+ Hiding _ -> unless' allowImplicit (checkImplicit HidingImport)

193205 Explicit [] -> unused

194206 Explicit declrefs -> checkExplicit declrefs

195207

@@ -197,39 +209,48 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

197209

198210 checkImplicit

199211 :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)

200− -> m ()

212+ -> m Bool

201213 checkImplicit warning =

202214 if null allRefs

203215 then unused

204− else tell $ errorMessage $ warning mni allRefs

216+ else warn (warning mni allRefs)

205217

206218 checkExplicit

207219 :: [DeclarationRef]

208− -> m ()

220+ -> m Bool

209221 checkExplicit declrefs = do

210222 let idents = nub (mapMaybe runDeclRef declrefs)

211− dctors = mapMaybe (matchDctor qualifierName) names

212− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

223+ dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names

224+ usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names

213225 diff = idents \\ usedNames

214− case (length diff, length idents) of

215− (0, _) -> return ()

226+

227+ didWarn <- case (length diff, length idents) of

228+ (0, _) -> return False

216229 (n, m) | n == m -> unused

217− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs

230+ _ -> warn (UnusedExplicitImport mni diff qualifierName allRefs)

218231

219− -- If we've not already warned a type is unused, check its data constructors

220− forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

232+ didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

221233 let allCtors = dctorsForType mni tn

222− when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of

223− (_, []) | c /= Just [] ->

224− tell $ errorMessage $ UnusedDctorImport tn

225− (Just ctors, dctors') ->

226− let ddiff = ctors \\ dctors'

227− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

228− _ -> return ()

229− return ()

230−

231− unused :: m ()

232− unused = tell $ errorMessage $ UnusedImport mni

234+ -- If we've not already warned a type is unused, check its data constructors

235+ unless' (runProperName tn `notElem` usedNames) $

236+ case (c, dctors `intersect` allCtors) of

237+ (_, []) | c /= Just [] -> warn (UnusedDctorImport tn)

238+ (Just ctors, dctors') ->

239+ let ddiff = ctors \\ dctors'

240+ in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff

241+ _ -> return False

242+

243+ return (didWarn || or didWarn')

244+

245+ unused :: m Bool

246+ unused = warn (UnusedImport mni)

247+

248+ warn :: SimpleErrorMessage -> m Bool

249+ warn err = tell (errorMessage err) >> return True

250+

251+ unless' :: Bool -> m Bool -> m Bool

252+ unless' True m = m

253+ unless' False _ = return False

233254

234255 allRefs :: [DeclarationRef]

235256 allRefs = findUsedRefs env mni qualifierName names

@@ -244,29 +265,27 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

244265 -> ProperName 'TypeName

245266 -> [ProperName 'ConstructorName]

246267 dctorsForType mn tn =

247− maybe [] getDctors (find matches $ dtys mn)

248− where

249− matches ((ty, _),_) = ty == tn

250− getDctors ((_,ctors),_) = ctors

268+ maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn)

251269

252270 typeForDCtor

253271 :: ModuleName

254272 -> ProperName 'ConstructorName

255273 -> Maybe (ProperName 'TypeName)

256− typeForDCtor mn pn =

257− getTy <$> find matches (dtys mn)

258− where

259− matches ((_, ctors), _) = pn `elem` ctors

260− getTy ((ty, _), _) = ty

274+ typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn)

261275

262−findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]

263−findUsedRefs env mni qualifierName names =

276+findUsedRefs

277+ :: Env

278+ -> ModuleName

279+ -> Maybe ModuleName

280+ -> [Qualified Name]

281+ -> [DeclarationRef]

282+findUsedRefs env mni qn names =

264283 let

265− classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

266− valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

267− typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names

268− types = mapMaybe (getTypeName qualifierName) names

269− dctors = mapMaybe (matchDctor qualifierName) names

284+ classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names

285+ valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names

286+ typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names

287+ types = mapMaybe (getTypeName <=< disqualifyFor qn) names

288+ dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names

270289 typesWithDctors = reconstructTypeRefs dctors

271290 typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

272291 typesRefs

@@ -281,7 +300,8 @@ findUsedRefs env mni qualifierName names =

281300 -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

282301 reconstructTypeRefs = foldr accumDctors M.empty

283302 where

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

303+ accumDctors dctor =

304+ M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

285305

286306 findTypeForDctor

287307 :: ModuleName

@@ -297,25 +317,13 @@ findUsedRefs env mni qualifierName names =

297317

298318matchName

299319 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

300− -> Maybe ModuleName

301320 -> Name

302321 -> Maybe String

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

304−matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

305−matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

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

307−matchName _ _ _ = Nothing

308−

309−extractQualName :: Name -> Maybe ModuleName

310−extractQualName (IdentName (Qualified q _)) = q

311−extractQualName (TyName (Qualified q _)) = q

312−extractQualName (TyOpName (Qualified q _)) = q

313−extractQualName (TyClassName (Qualified q _)) = q

314−extractQualName (DctorName (Qualified q _)) = q

315−

316−matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)

317−matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

318−matchDctor _ _ = Nothing

322+matchName _ (IdentName x) = Just $ showIdent x

323+matchName _ (TyName x) = Just $ runProperName x

324+matchName _ (TyClassName x) = Just $ runProperName x

325+matchName lookupDc (DctorName x) = runProperName <$> lookupDc x

326+matchName _ _ = Nothing

319327

320328runDeclRef :: DeclarationRef -> Maybe String

321329runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

@@ -324,15 +332,38 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

324332runDeclRef (TypeClassRef pn) = Just $ runProperName pn

325333runDeclRef _ = Nothing

326334

327−getTypeRef

328− :: DeclarationRef

329− -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

330−getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

331−getTypeRef (TypeRef pn x) = Just (pn, x)

332−getTypeRef _ = Nothing

333−

334−addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

335−addModuleLocError sp err =

336− case sp of

337− Just pos -> withPosition pos err

338− _ -> err

335+checkDuplicateImports

336+ :: MonadWriter MultipleErrors m

337+ => ModuleName

338+ -> [ImportDef]

339+ -> (ImportDef, ImportDef)

340+ -> m [ImportDef]

341+checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

342+ if t1 == t2 && q1 == q2

343+ then do

344+ maybe id warnWithPosition pos $

345+ tell $ errorMessage $ DuplicateImport mn t2 q2

346+ return $ (pos, t2, q2) : xs

347+ else return xs

348+

349+-- |

350+-- Checks that an import with a hiding reference is not hiding all possible

351+-- imports.

352+--

353+checkEmptyImport

354+ :: MonadWriter MultipleErrors m

355+ => ModuleName

356+ -> Imports

357+ -> ImportDeclarationType

358+ -> m ()

359+checkEmptyImport importModule imps (Hiding _) = do

360+ let isEmptyImport

361+ = M.null (importedTypes imps)

362+ && M.null (importedTypeOps imps)

363+ && M.null (importedDataConstructors imps)

364+ && M.null (importedTypeClasses imps)

365+ && M.null (importedValues imps)

366+ && M.null (importedValueOps imps)

367+ when isEmptyImport . tell . errorMessage $

368+ RedundantEmptyHidingImport importModule

369+checkEmptyImport _ _ _ = return ()

src/Language/PureScript/Make.hs+2−4

@@ -19,7 +19,6 @@ module Language.PureScript.Make

1919

2020import Prelude.Compat

2121

22−import Control.Applicative ((<|>))

2322import Control.Concurrent.Lifted as C

2423import Control.Monad hiding (sequence)

2524import Control.Monad.Base (MonadBase(..))

@@ -361,7 +360,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

361360 genSourceMap dir mapFile extraLines mappings = do

362361 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)

363362 sourceFile = case mappings of

364− ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file

363+ (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file

365364 _ -> Nothing

366365 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

367366 map (\(SMap _ orig gen) -> Mapping {

@@ -450,11 +449,10 @@ checkForeignDecls m path = do

450449 (errs, _) ->

451450 Left errs

452451

453− -- TODO: Handling for parenthesised operators should be removed after 0.9.

454452 -- We ignore the error message here, just being told it's an invalid

455453 -- identifier should be enough.

456454 parseIdent :: String -> Either String Ident

457− parseIdent str = try str <|> try ("(" ++ str ++ ")")

455+ parseIdent str = try str

458456 where

459457 try s = either (const (Left str)) Right $ do

460458 ts <- PSParser.lex "" s

src/Language/PureScript/ModuleDependencies.hs+6−2

@@ -69,8 +69,8 @@ usedModules ams d =

6969 -- Regardless of whether an imported module is qualified we still need to

7070 -- take into account its import to build an accurate list of dependencies.

7171 [mn]

72− forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _)))

73− | mn `notElem` ams = [mn]

72+ forDecls (FixityDeclaration fd)

73+ | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]

7474 forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)

7575 | mn `notElem` ams = [mn]

7676 forDecls _ = []

@@ -87,6 +87,10 @@ usedModules ams d =

8787 | mn `notElem` ams = [mn]

8888 forTypes _ = []

8989

90+ extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName

91+ extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn

92+ extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn

93+

9094-- |

9195-- Convert a strongly connected component of the module graph to a module

9296--

src/Language/PureScript/Names.hs+75−12

@@ -7,13 +7,51 @@ module Language.PureScript.Names where

88import Prelude.Compat

10−import Control.Monad (liftM)

1110import Control.Monad.Supply.Class

1211

1312import Data.Aeson

1413import Data.Aeson.TH

1514import Data.List

1615

16+-- | A sum of the possible name types, useful for error and lint messages.

17+data Name

18+ = IdentName Ident

19+ | ValOpName (OpName 'ValueOpName)

20+ | TyName (ProperName 'TypeName)

21+ | TyOpName (OpName 'TypeOpName)

22+ | DctorName (ProperName 'ConstructorName)

23+ | TyClassName (ProperName 'ClassName)

24+ | ModName ModuleName

25+ deriving (Eq, Show)

26+

27+getIdentName :: Name -> Maybe Ident

28+getIdentName (IdentName name) = Just name

29+getIdentName _ = Nothing

30+

31+getValOpName :: Name -> Maybe (OpName 'ValueOpName)

32+getValOpName (ValOpName name) = Just name

33+getValOpName _ = Nothing

34+

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

36+getTypeName (TyName name) = Just name

37+getTypeName _ = Nothing

38+

39+getTypeOpName :: Name -> Maybe (OpName 'TypeOpName)

40+getTypeOpName (TyOpName name) = Just name

41+getTypeOpName _ = Nothing

42+

43+getDctorName :: Name -> Maybe (ProperName 'ConstructorName)

44+getDctorName (DctorName name) = Just name

45+getDctorName _ = Nothing

46+

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

48+getClassName (TyClassName name) = Just name

49+getClassName _ = Nothing

50+

51+getModName :: Name -> Maybe ModuleName

52+getModName (ModName name) = Just name

53+getModName _ = Nothing

54+

1755-- |

1856-- Names for value identifiers

1957--

@@ -23,10 +61,6 @@ data Ident

2361 --

2462 = Ident String

2563 -- |

26− -- A symbolic name for an infix operator

27− --

28− | Op String

29− -- |

3064 -- A generated name for an identifier

3165 --

3266 | GenIdent (Maybe String) Integer

@@ -34,19 +68,37 @@ data Ident

3468

3569runIdent :: Ident -> String

3670runIdent (Ident i) = i

37−runIdent (Op op) = op

3871runIdent (GenIdent Nothing n) = "$" ++ show n

3972runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

4073

4174showIdent :: Ident -> String

42−showIdent (Op op) = '(' : op ++ ")"

43−showIdent i = runIdent i

75+showIdent = runIdent

4476

45−freshIdent :: (MonadSupply m) => String -> m Ident

46−freshIdent name = liftM (GenIdent (Just name)) fresh

77+freshIdent :: MonadSupply m => String -> m Ident

78+freshIdent name = GenIdent (Just name) <$> fresh

4779

48−freshIdent' :: (MonadSupply m) => m Ident

49−freshIdent' = liftM (GenIdent Nothing) fresh

80+freshIdent' :: MonadSupply m => m Ident

81+freshIdent' = GenIdent Nothing <$> fresh

82+

83+-- |

84+-- Operator alias names.

85+--

86+newtype OpName (a :: OpNameType) = OpName { runOpName :: String }

87+ deriving (Show, Read, Eq, Ord)

88+

89+instance ToJSON (OpName a) where

90+ toJSON = toJSON . runOpName

91+

92+instance FromJSON (OpName a) where

93+ parseJSON = fmap OpName . parseJSON

94+

95+showOp :: OpName a -> String

96+showOp op = '(' : runOpName op ++ ")"

97+

98+-- |

99+-- The closed set of operator alias types.

100+--

101+data OpNameType = ValueOpName | TypeOpName

50102

51103-- |

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

@@ -100,6 +152,9 @@ showQualified :: (a -> String) -> Qualified a -> String

100152showQualified f (Qualified Nothing a) = f a

101153showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

102154

155+getQual :: Qualified a -> Maybe ModuleName

156+getQual (Qualified mn _) = mn

157+

103158-- |

104159-- Provide a default module name, if a name is unqualified

105160--

@@ -117,6 +172,14 @@ mkQualified name mn = Qualified (Just mn) name

117172disqualify :: Qualified a -> a

118173disqualify (Qualified _ a) = a

119174

175+-- |

176+-- Remove the qualification from a value when it is qualified with a particular

177+-- module name.

178+--

179+disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a

180+disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a

181+disqualifyFor _ _ = Nothing

182+

120183-- |

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

122185--

src/Language/PureScript/Parser/Common.hs+8−2

@@ -43,10 +43,16 @@ parseQualified parser = part []

4343 qual path = if null path then Nothing else Just $ ModuleName path

4444

4545-- |

46−-- Parse an identifier or parenthesized operator

46+-- Parse an identifier.

4747--

4848parseIdent :: TokenParser Ident

49−parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)

49+parseIdent = Ident <$> identifier

50+

51+-- |

52+-- Parse an operator.

53+--

54+parseOperator :: TokenParser (OpName a)

55+parseOperator = OpName <$> symbol

5056

5157-- |

5258-- Run the first parser, then match the second if possible, applying the specified function on a successful match

src/Language/PureScript/Parser/Declarations.hs+24−17

@@ -42,7 +42,10 @@ import qualified Text.Parsec.Expr as P

4242-- |

4343-- Read source position information

4444--

45−withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a

45+withSourceSpan

46+ :: (SourceSpan -> [Comment] -> a -> a)

47+ -> P.Parsec [PositionedToken] u a

48+ -> P.Parsec [PositionedToken] u a

4649withSourceSpan f p = do

4750 start <- P.getPosition

4851 comments <- C.readComments

@@ -123,13 +126,17 @@ parseFixityDeclaration :: TokenParser Declaration

123126parseFixityDeclaration = do

124127 fixity <- parseFixity

125128 indented

126− alias <- P.optionMaybe $ parseQualified aliased <* reserved "as"

127− name <- symbol

128− return $ FixityDeclaration fixity name alias

129+ FixityDeclaration

130+ <$> ((Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity))

129131 where

130− aliased = (AliasValue . Ident <$> identifier)

131− <|> (AliasConstructor <$> properName)

132− <|> reserved "type" *> (AliasType <$> properName)

132+ typeFixity fixity =

133+ TypeFixity fixity

134+ <$> (reserved "type" *> parseQualified properName)

135+ <*> (reserved "as" *> parseOperator)

136+ valueFixity fixity =

137+ ValueFixity fixity

138+ <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> properName))

139+ <*> (reserved "as" *> parseOperator)

133140

134141parseImportDeclaration :: TokenParser Declaration

135142parseImportDeclaration = do

@@ -154,10 +161,11 @@ parseDeclarationRef :: TokenParser DeclarationRef

154161parseDeclarationRef =

155162 withSourceSpan PositionedDeclarationRef

156163 $ (ValueRef <$> parseIdent)

164+ <|> (ValueOpRef <$> parens parseOperator)

157165 <|> parseTypeRef

158166 <|> (TypeClassRef <$> (reserved "class" *> properName))

159167 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

160− <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol)))

168+ <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator))

161169 where

162170 parseTypeRef = do

163171 name <- properName

@@ -323,8 +331,7 @@ parseIdentifierAndValue =

323331parseAbs :: TokenParser Expr

324332parseAbs = do

325333 symbol' "\\"

326− -- TODO: remove this 'try' after operator aliases are finished (0.9)

327− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

334+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens)))

328335 C.indented *> rarrow

329336 value <- parseValue

330337 return $ toFunction args value

@@ -343,7 +350,7 @@ parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (

343350 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

344351

345352parseCaseAlternative :: TokenParser CaseAlternative

346−parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)

353+parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

347354 <*> (Left <$> (C.indented *>

348355 P.many1 ((,) <$> parseGuard

349356 <*> (indented *> rarrow *> parseValue)

@@ -383,6 +390,7 @@ parseValueAtom = P.choice

383390 , parseDo

384391 , parseLet

385392 , P.try $ Parens <$> parens parseValue

393+ , Op <$> parseQualified (parens parseOperator)

386394 , parseHole

387395 ]

388396

@@ -390,8 +398,9 @@ parseValueAtom = P.choice

390398-- Parse an expression in backticks or an operator

391399--

392400parseInfixExpr :: TokenParser Expr

393−parseInfixExpr = P.between tick tick parseValue

394− <|> Var <$> parseQualified (Op <$> symbol)

401+parseInfixExpr

402+ = P.between tick tick parseValue

403+ <|> Op <$> parseQualified parseOperator

395404

396405parseHole :: TokenParser Expr

397406parseHole = Hole <$> holeLit

@@ -481,9 +490,7 @@ parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinde

481490

482491parseVarOrNamedBinder :: TokenParser Binder

483492parseVarOrNamedBinder = do

484− -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed

485− -- any more since identifiers in binders won't be 'Op's.

486− name <- P.try C.parseIdent

493+ name <- C.parseIdent

487494 let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)

488495 parseNamedBinder <|> return (VarBinder name)

489496

@@ -522,7 +529,7 @@ parseBinder =

522529 ]

523530

524531 parseOpBinder :: TokenParser Binder

525− parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)

532+ parseOpBinder = OpBinder <$> parseQualified parseOperator

526533

527534parseBinderAtom :: TokenParser Binder

528535parseBinderAtom = P.choice

src/Language/PureScript/Parser/Types.hs+1−2

@@ -12,7 +12,6 @@ import Control.Monad (when, unless)

1212

1313import Language.PureScript.AST.SourcePos

1414import Language.PureScript.Environment

15−import Language.PureScript.Names

1615import Language.PureScript.Parser.Common

1716import Language.PureScript.Parser.Kinds

1817import Language.PureScript.Parser.Lexer

@@ -83,7 +82,7 @@ parseAnyType :: TokenParser Type

8382parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

8483 where

8584 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

86− , [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident ->

85+ , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->

8786 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

8887 ]

8988 , [ P.Infix (rarrow >> return function) P.AssocRight ]

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

@@ -40,7 +40,7 @@ typeLiterals = mkPattern match

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

4141 match (BinaryNoParensType op l r) =

4242 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r

43− match (TypeOp op) = Just $ text $ showQualified runIdent op

43+ match (TypeOp op) = Just $ text $ showQualified runOpName op

4444 match _ = Nothing

4545

4646constraintsAsBox :: [Constraint] -> Box -> Box

src/Language/PureScript/Pretty/Values.hs+3−2

@@ -71,6 +71,7 @@ prettyPrintValue _ (Hole name) = text "?" <> text name

7171prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

7272prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

7373prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

74+prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr

7475prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr

7576prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr

7677prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

@@ -85,7 +86,7 @@ prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

8586prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

8687 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

8788 where

88− printOp (Var (Qualified _ (Op opName))) = text opName

89+ printOp (Op (Qualified _ name)) = text (runOpName name)

8990 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

9091prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

9192prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

@@ -154,7 +155,7 @@ prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

154155prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

155156prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

156157prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

157−prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)

158+prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op)

158159prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

159160 prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

160161prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

src/Language/PureScript/Sugar.hs+13−7

@@ -3,14 +3,15 @@

33--

44module Language.PureScript.Sugar (desugar, module S) where

6−import Prelude.Compat

7−

86import Control.Category ((>>>))

97import Control.Monad

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

119import Control.Monad.Supply.Class

1210import Control.Monad.Writer.Class (MonadWriter())

1311

12+import Data.List (map)

13+import Data.Traversable (traverse)

14+

1415import Language.PureScript.AST

1516import Language.PureScript.Errors

1617import Language.PureScript.Externs

@@ -47,15 +48,20 @@ import Language.PureScript.Sugar.TypeDeclarations as S

4748--

4849-- * Group mutually recursive value and data declarations into binding groups.

4950--

50−desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

51+desugar

52+ :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

53+ => [ExternsFile]

54+ -> [Module]

55+ -> m [Module]

5156desugar externs =

52− map removeSignedLiterals

57+ map desugarSignedLiterals

5358 >>> traverse desugarObjectConstructors

5459 >=> traverse desugarDoModule

55− >=> desugarCasesModule

56− >=> desugarTypeDeclarationsModule

60+ >=> traverse desugarCasesModule

61+ >=> traverse desugarTypeDeclarationsModule

5762 >=> desugarImports externs

5863 >=> rebracket externs

64+ >=> traverse checkFixityExports

5965 >=> traverse deriveInstances

6066 >=> desugarTypeClasses externs

61− >=> createBindingGroupsModule

67+ >=> traverse createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+18−19

@@ -31,11 +31,10 @@ import Language.PureScript.Types

3131--

3232createBindingGroupsModule

3333 :: (MonadError MultipleErrors m)

34− => [Module]

35− -> m [Module]

36−createBindingGroupsModule =

37− mapM $ \(Module ss coms name ds exps) ->

38− Module ss coms name <$> createBindingGroups name ds <*> pure exps

34+ => Module

35+ -> m Module

36+createBindingGroupsModule (Module ss coms name ds exps) =

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

3938

4039-- |

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

@@ -67,11 +66,11 @@ createBindingGroups moduleName = mapM f <=< handleDecls

6766 handleDecls ds = do

6867 let values = filter isValueDecl ds

6968 dataDecls = filter isDataDecl ds

70− allProperNames = map getTypeName dataDecls

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

69+ allProperNames = map declTypeName dataDecls

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

7271 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

73− let allIdents = map getIdent values

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

72+ let allIdents = map declIdent values

73+ valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values

7574 bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

7675 return $ filter isImportDecl ds ++

7776 filter isExternDataDecl ds ++

@@ -149,16 +148,16 @@ usedTypeNames moduleName =

149148 | moduleName == moduleName' = [name]

150149 usedNames _ = []

151150

152−getIdent :: Declaration -> Ident

153−getIdent (ValueDeclaration ident _ _ _) = ident

154−getIdent (PositionedDeclaration _ _ d) = getIdent d

155−getIdent _ = internalError "Expected ValueDeclaration"

151+declIdent :: Declaration -> Ident

152+declIdent (ValueDeclaration ident _ _ _) = ident

153+declIdent (PositionedDeclaration _ _ d) = declIdent d

154+declIdent _ = internalError "Expected ValueDeclaration"

156155

157−getTypeName :: Declaration -> ProperName 'TypeName

158−getTypeName (DataDeclaration _ pn _ _) = pn

159−getTypeName (TypeSynonymDeclaration pn _ _) = pn

160−getTypeName (PositionedDeclaration _ _ d) = getTypeName d

161−getTypeName _ = internalError "Expected DataDeclaration"

156+declTypeName :: Declaration -> ProperName 'TypeName

157+declTypeName (DataDeclaration _ pn _ _) = pn

158+declTypeName (TypeSynonymDeclaration pn _ _) = pn

159+declTypeName (PositionedDeclaration _ _ d) = declTypeName d

160+declTypeName _ = internalError "Expected DataDeclaration"

162161

163162-- |

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

@@ -187,7 +186,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

187186 idents = map (\(_, i, _) -> i) valueVerts

188187

189188 valueVerts :: [(Declaration, Ident, [Ident])]

190− valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

189+ valueVerts = map (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

191190

192191 toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)

193192 toBinding (AcyclicSCC d) = return $ fromValueDecl d

src/Language/PureScript/Sugar/CaseDeclarations.hs+9−4

@@ -12,7 +12,7 @@ import Prelude.Compat

1212import Data.List (nub, groupBy, foldl1')

1313import Data.Maybe (catMaybes, mapMaybe)

1414

15−import Control.Monad ((<=<), forM, replicateM, join, unless)

15+import Control.Monad ((<=<), replicateM, join, unless)

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

1717import Control.Monad.Supply.Class

1818

@@ -32,10 +32,15 @@ isLeft (Right _) = False

3232-- |

3333-- Replace all top-level binders in a module with case expressions.

3434--

35−desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

36−desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

35+desugarCasesModule

36+ :: (MonadSupply m, MonadError MultipleErrors m)

37+ => Module

38+ -> m Module

39+desugarCasesModule (Module ss coms name ds exps) =

3740 rethrow (addHint (ErrorInModule name)) $

38− Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps

41+ Module ss coms name

42+ <$> (desugarCases <=< desugarAbs <=< validateCases $ ds)

43+ <*> pure exps

3944

4045-- |

4146-- Validates that case head and binder lengths match.

src/Language/PureScript/Sugar/Names.hs+60−69

@@ -37,7 +37,12 @@ import Language.PureScript.Types

3737-- Replaces all local names with qualified names within a list of modules. The

3838-- modules should be topologically sorted beforehand.

3939--

40−desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

40+desugarImports

41+ :: forall m

42+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

43+ => [ExternsFile]

44+ -> [Module]

45+ -> m [Module]

4146desugarImports externs modules =

4247 fmap snd (desugarImportsWithEnv externs modules)

4348

@@ -63,7 +68,7 @@ desugarImportsWithEnv externs modules = do

6368 env' = M.insert efModuleName (ss, nullImports, members) env

6469 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])

6570 imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

66− exps <- resolveExports env' efModuleName imps members efExports

71+ exps <- resolveExports env' ss efModuleName imps members efExports

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

6873 where

6974

@@ -77,24 +82,18 @@ desugarImportsWithEnv externs modules = do

7782 forTyCon _ = Nothing

7883 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

7984 toExportedType _ = Nothing

80− exportedTypeOps :: [(Ident, ModuleName)]

81− exportedTypeOps = mapMaybe toExportedTypeOp efExports

82− where

83− toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName)

84− toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r

85− toExportedTypeOp _ = Nothing

85+

86+ exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

87+ exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports

88+

8689 exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

87− exportedTypeClasses = mapMaybe toExportedTypeClass efExports

88− where

89− toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

90− toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r

91− toExportedTypeClass _ = Nothing

90+ exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports

91+

9292 exportedValues :: [(Ident, ModuleName)]

93− exportedValues = mapMaybe toExportedValue efExports

94− where

95− toExportedValue (ValueRef ident) = Just (ident, efModuleName)

96− toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

97− toExportedValue _ = Nothing

93+ exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports

94+

95+ exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

96+ exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports

9897

9998 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

10099 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

@@ -104,7 +103,7 @@ desugarImportsWithEnv externs modules = do

104103 members <- findExportable m

105104 let env' = M.insert mn (ss, nullImports, members) env

106105 (m', imps) <- resolveImports env' m

107− exps <- maybe (return members) (resolveExports env' mn imps members) refs

106+ exps <- maybe (return members) (resolveExports env' ss mn imps members) refs

108107 return (m' : ms, M.insert mn (ss, imps, exps) env)

109108

110109 renameInModule' :: Env -> Module -> m Module

@@ -127,6 +126,7 @@ elaborateExports exps (Module ss coms mn decls refs) =

127126 map TypeOpRef (my exportedTypeOps) ++

128127 map TypeClassRef (my exportedTypeClasses) ++

129128 map ValueRef (my exportedValues) ++

129+ map ValueOpRef (my exportedValueOps) ++

130130 maybe [] (filter isModuleRef) refs

131131 where

132132 -- Extracts a list of values from the exports and filters out any values that

@@ -169,16 +169,12 @@ renameInModule env imports (Module ss coms mn decls exps) =

169169 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

170170 updateDecl (pos, bound) (ExternDeclaration name ty) =

171171 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

172− updateDecl (pos, bound) (FixityDeclaration fx name alias) =

173− (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias)

174− where

175− updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias)

176− updateAlias (Qualified mn' (AliasValue ident)) =

177− fmap AliasValue <$> updateValueName (Qualified mn' ident) pos

178− updateAlias (Qualified mn' (AliasConstructor ctor)) =

179− fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos

180− updateAlias (Qualified mn' (AliasType ty)) =

181− fmap AliasType <$> updateTypeName (Qualified mn' ty) pos

172+ updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) =

173+ (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op)

174+ updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) =

175+ (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op)

176+ updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) =

177+ (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op)

182178 updateDecl s d = return (s, d)

183179

184180 updateValue

@@ -199,6 +195,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

199195 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

200196 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

201197 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

198+ updateValue (pos, bound) (Op op) =

199+ (,) (pos, bound) <$> (Op <$> updateValueOpName op pos)

202200 updateValue s@(pos, _) (Constructor name) =

203201 (,) s <$> (Constructor <$> updateDataConstructorName name pos)

204202 updateValue s@(pos, _) (TypedValue check val ty) =

@@ -213,8 +211,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

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

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

215213 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

216− updateBinder s@(pos, _) (OpBinder name) =

217− (,) s <$> (OpBinder <$> updateValueName name pos)

214+ updateBinder s@(pos, _) (OpBinder op) =

215+ (,) s <$> (OpBinder <$> updateValueOpName op pos)

218216 updateBinder s (TypedBinder t b) = do

219217 (s'@ (span', _), b') <- updateBinder s b

220218 t' <- updateTypesEverywhere span' t

@@ -254,23 +252,14 @@ renameInModule env imports (Module ss coms mn decls exps) =

254252 -> Maybe SourceSpan

255253 -> m (Qualified (ProperName 'TypeName))

256254 updateTypeName =

257− update UnknownType

258− (importedTypes imports)

259− (resolveType . exportedTypes)

260− TyName

261− (("type " ++) . runProperName)

255+ update (importedTypes imports) (resolveType . exportedTypes) TyName

262256

263257 updateTypeOpName

264− :: Qualified Ident

258+ :: Qualified (OpName 'TypeOpName)

265259 -> Maybe SourceSpan

266− -> m (Qualified Ident)

260+ -> m (Qualified (OpName 'TypeOpName))

267261 updateTypeOpName =

268− update

269− UnknownTypeOp

270− (importedTypeOps imports)

271− (resolve . exportedTypeOps)

272− TyOpName

273− (("type operator" ++) . runIdent)

262+ update (importedTypeOps imports) (resolve . exportedTypeOps) TyOpName

274263

275264 updateDataConstructorName

276265 :: Qualified (ProperName 'ConstructorName)

@@ -278,11 +267,9 @@ renameInModule env imports (Module ss coms mn decls exps) =

278267 -> m (Qualified (ProperName 'ConstructorName))

279268 updateDataConstructorName =

280269 update

281− (flip UnknownDataConstructor Nothing)

282270 (importedDataConstructors imports)

283271 (resolveDctor . exportedTypes)

284272 DctorName

285− (("data constructor " ++) . runProperName)

286273

287274 updateClassName

288275 :: Qualified (ProperName 'ClassName)

@@ -290,20 +277,20 @@ renameInModule env imports (Module ss coms mn decls exps) =

290277 -> m (Qualified (ProperName 'ClassName))

291278 updateClassName =

292279 update

293− UnknownTypeClass

294280 (importedTypeClasses imports)

295281 (resolve . exportedTypeClasses)

296282 TyClassName

297− (("class " ++) . runProperName)

298283

299284 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

300285 updateValueName =

301− update

302− UnknownValue

303− (importedValues imports)

304− (resolve . exportedValues)

305− IdentName

306− (("value " ++) . runIdent)

286+ update (importedValues imports) (resolve . exportedValues) IdentName

287+

288+ updateValueOpName

289+ :: Qualified (OpName 'ValueOpName)

290+ -> Maybe SourceSpan

291+ -> m (Qualified (OpName 'ValueOpName))

292+ updateValueOpName =

293+ update (importedValueOps imports) (resolve . exportedValueOps) ValOpName

307294

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

309296 -- module of original definition.

@@ -316,7 +303,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

316303 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

317304 -> ProperName 'TypeName

318305 -> Maybe (Qualified (ProperName 'TypeName))

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

306+ resolveType tys name =

307+ mkQualified name . snd <$> find ((== name) . fst . fst) tys

320308

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

322310 -- module of original definition.

@@ -324,22 +312,21 @@ renameInModule env imports (Module ss coms mn decls exps) =

324312 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

325313 -> ProperName 'ConstructorName

326314 -> Maybe (Qualified (ProperName 'ConstructorName))

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

315+ resolveDctor tys name =

316+ mkQualified name . snd <$> find (elem name . snd . fst) tys

328317

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

330319 -- qualified references are replaced with their canoncial qualified names

331320 -- (e.g. M.Map -> Data.Map.Map).

332321 update

333322 :: (Ord a, Show a)

334− => (Qualified a -> SimpleErrorMessage)

335− -> M.Map (Qualified a) [ImportRecord a]

323+ => M.Map (Qualified a) [ImportRecord a]

336324 -> (Exports -> a -> Maybe (Qualified a))

337− -> (Qualified a -> Name)

338− -> (a -> String)

325+ -> (a -> Name)

339326 -> Qualified a

340327 -> Maybe SourceSpan

341328 -> m (Qualified a)

342− update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $

329+ update imps getE toName qname@(Qualified mn' name) pos = positioned $

343330 case (M.lookup qname imps, mn') of

344331

345332 -- We found the name in our imports, so we return the name for it,

@@ -348,19 +335,25 @@ renameInModule env imports (Module ss coms mn decls exps) =

348335 -- re-exports. If there are multiple options for the name to resolve to

349336 -- in scope, we throw an error.

350337 (Just options, _) -> do

351− (mnNew, mnOrig) <- checkImportConflicts mn render options

352− modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

338+ (mnNew, mnOrig) <- checkImportConflicts mn toName options

339+ modify $ \result ->

340+ M.insert

341+ mnNew

342+ (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result))

343+ result

353344 return $ Qualified (Just mnOrig) name

354345

355346 -- If the name wasn't found in our imports but was qualified then we need

356347 -- to check whether it's a failed import from a "pseudo" module (created

357348 -- by qualified importing). If that's not the case, then we just need to

358349 -- check it refers to a symbol in another module.

359− (Nothing, Just mn'') -> do

350+ (Nothing, Just mn'') ->

360351 case M.lookup mn'' env of

361352 Nothing

362353 | mn'' `S.member` importedVirtualModules imports -> throwUnknown

363− | otherwise -> throwError . errorMessage $ UnknownModule mn''

354+ | otherwise ->

355+ throwError . errorMessage .

356+ UnknownName . Qualified Nothing $ ModName mn''

364357 Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

365358

366359 -- If neither of the above cases are true then it's an undefined or

@@ -368,7 +361,5 @@ renameInModule env imports (Module ss coms mn decls exps) =

368361 _ -> throwUnknown

369362

370363 where

371− positioned err = case pos of

372− Nothing -> err

373− Just pos' -> rethrowWithPosition pos' err

374− throwUnknown = throwError . errorMessage $ unknown qname

364+ positioned err = maybe err (`rethrowWithPosition` err) pos

365+ throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname

src/Language/PureScript/Sugar/Names/Common.hsnew file+66

@@ -0,0 +1,66 @@

1+module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where

3+import Prelude.Compat

5+import Control.Monad.Writer (MonadWriter(..))

7+import Data.Foldable (for_)

8+import Data.Function (on)

9+import Data.List (nub, nubBy, (\\))

10+import Data.Maybe (mapMaybe)

11+

12+import Language.PureScript.AST

13+import Language.PureScript.Errors

14+import Language.PureScript.Names

15+

16+-- |

17+-- Warns about duplicate values in a list of declaration refs.

18+--

19+warnDuplicateRefs

20+ :: MonadWriter MultipleErrors m

21+ => SourceSpan

22+ -> (Name -> SimpleErrorMessage)

23+ -> [DeclarationRef]

24+ -> m ()

25+warnDuplicateRefs pos toError refs = do

26+ let withoutCtors = deleteCtors `map` refs

27+ dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors

28+ dupeCtors = concat $ mapMaybe (extractCtors pos) refs

29+

30+ for_ (dupeRefs ++ dupeCtors) $ \(pos', name) ->

31+ warnWithPosition pos' . tell . errorMessage $ toError name

32+

33+ where

34+

35+ -- Returns a DeclarationRef unwrapped from any PositionedDeclarationRef

36+ -- constructor(s) it may be wrapped within. Used so position info is ignored

37+ -- when making the comparison for duplicates.

38+ withoutPosInfo :: DeclarationRef -> DeclarationRef

39+ withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref

40+ withoutPosInfo other = other

41+

42+ -- Deletes the constructor information from TypeRefs so that only the

43+ -- referenced type is used in the duplicate check - constructors are handled

44+ -- separately

45+ deleteCtors :: DeclarationRef -> DeclarationRef

46+ deleteCtors (TypeRef pn _) = TypeRef pn Nothing

47+ deleteCtors other = other

48+

49+ -- Extracts the names of duplicate constructor references from TypeRefs.

50+ extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]

51+ extractCtors pos' (TypeRef _ (Just dctors)) =

52+ let dupes = dctors \\ nub dctors

53+ in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes

54+ extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref

55+ extractCtors _ _ = Nothing

56+

57+ -- Converts a DeclarationRef into a name for an error message.

58+ refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name)

59+ refToName pos' (TypeRef name _) = Just (pos', TyName name)

60+ refToName pos' (TypeOpRef op) = Just (pos', TyOpName op)

61+ refToName pos' (ValueRef name) = Just (pos', IdentName name)

62+ refToName pos' (ValueOpRef op) = Just (pos', ValOpName op)

63+ refToName pos' (TypeClassRef name) = Just (pos', TyClassName name)

64+ refToName pos' (ModuleRef name) = Just (pos', ModName name)

65+ refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref

66+ refToName _ _ = Nothing

src/Language/PureScript/Sugar/Names/Env.hs+106−40

@@ -14,6 +14,7 @@ module Language.PureScript.Sugar.Names.Env

1414 , exportTypeOp

1515 , exportTypeClass

1616 , exportValue

17+ , exportValueOp

1718 , getExports

1819 , checkImportConflicts

1920 ) where

@@ -26,12 +27,11 @@ import Control.Monad.Writer.Class (MonadWriter(..))

2627

2728import Data.Function (on)

2829import Data.List (groupBy, sortBy, nub, delete)

29−import Data.Maybe (fromJust)

30+import Data.Maybe (fromJust, mapMaybe)

3031import qualified Data.Map as M

3132import qualified Data.Set as S

3233

3334import Language.PureScript.AST

34−import Language.PureScript.Crash

3535import Language.PureScript.Environment

3636import Language.PureScript.Errors

3737import Language.PureScript.Names

@@ -60,6 +60,8 @@ data ImportProvenance

6060 | Local

6161 deriving (Eq, Ord, Show, Read)

6262

63+type ImportMap a = M.Map (Qualified a) [ImportRecord a]

64+

6365-- |

6466-- The imported declarations for a module, including the module's own members.

6567--

@@ -68,23 +70,27 @@ data Imports = Imports

6870 -- |

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

7072 --

71− importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]

73+ importedTypes :: ImportMap (ProperName 'TypeName)

7274 -- |

7375 -- Local names for type operators within a module mapped to to their qualified names

7476 --

75− , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident]

77+ , importedTypeOps :: ImportMap (OpName 'TypeOpName)

7678 -- |

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

7880 --

79− , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]

81+ , importedDataConstructors :: ImportMap (ProperName 'ConstructorName)

8082 -- |

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

8284 --

83− , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]

85+ , importedTypeClasses :: ImportMap (ProperName 'ClassName)

8486 -- |

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

8688 --

87− , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident]

89+ , importedValues :: ImportMap Ident

90+ -- |

91+ -- Local names for value operators within a module mapped to to their qualified names

92+ --

93+ , importedValueOps :: ImportMap (OpName 'ValueOpName)

8894 -- |

8995 -- The modules that have been imported into the current scope.

9096 --

@@ -100,7 +106,7 @@ data Imports = Imports

100106-- An empty 'Imports' value.

101107--

102108nullImports :: Imports

103−nullImports = Imports M.empty M.empty M.empty M.empty M.empty S.empty S.empty

109+nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty

104110

105111-- |

106112-- The exported declarations from a module.

@@ -116,7 +122,7 @@ data Exports = Exports

116122 -- The type operators exported from each module along with the module they

117123 -- originally came from.

118124 --

119− , exportedTypeOps :: [(Ident, ModuleName)]

125+ , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

120126 -- |

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

122128 -- came from.

@@ -127,13 +133,18 @@ data Exports = Exports

127133 -- came from.

128134 --

129135 , exportedValues :: [(Ident, ModuleName)]

136+ -- |

137+ -- The value operators exported from each module along with the module they

138+ -- originally came from.

139+ --

140+ , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

130141 } deriving (Show, Read)

131142

132143-- |

133144-- An empty 'Exports' value.

134145--

135146nullExports :: Exports

136−nullExports = Exports [] [] [] []

147+nullExports = Exports [] [] [] [] []

137148

138149-- |

139150-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -164,7 +175,11 @@ envModuleExports (_, _, exps) = exps

164175-- The exported types from the @Prim@ module

165176--

166177primExports :: Exports

167−primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) []

178+primExports =

179+ nullExports

180+ { exportedTypes = mkTypeEntry `map` M.keys primTypes

181+ , exportedTypeClasses = mkClassEntry `map` M.keys primClasses

182+ }

168183 where

169184 mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

170185 mkClassEntry (Qualified mn name) = (name, fromJust mn)

@@ -179,53 +194,100 @@ primEnv = M.singleton

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

180195-- error if a conflict occurs.

181196--

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

197+exportType

198+ :: MonadError MultipleErrors m

199+ => Exports

200+ -> ProperName 'TypeName

201+ -> [ProperName 'ConstructorName]

202+ -> ModuleName

203+ -> m Exports

183204exportType exps name dctors mn = do

184205 let exTypes' = exportedTypes exps

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

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

187208 let exClasses = exportedTypeClasses exps

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

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

209+ when (any ((== name) . fst . fst) exTypes) $

210+ throwConflictError ConflictingTypeDecls name

211+ when (any ((== coerceProperName name) . fst) exClasses) $

212+ throwConflictError TypeConflictsWithClass name

190213 forM_ dctors $ \dctor -> do

191− when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

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

214+ when (dctor `elem` exDctors) $

215+ throwConflictError ConflictingCtorDecls dctor

216+ when (any ((== coerceProperName dctor) . fst) exClasses) $

217+ throwConflictError CtorConflictsWithClass dctor

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

194219

195220-- |

196221-- Safely adds a type operator to some exports, returning an error if a

197222-- conflict occurs.

198223--

199−exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

200−exportTypeOp exps name mn = do

201− typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps)

224+exportTypeOp

225+ :: MonadError MultipleErrors m

226+ => Exports

227+ -> OpName 'TypeOpName

228+ -> ModuleName

229+ -> m Exports

230+exportTypeOp exps op mn = do

231+ typeOps <- addExport DuplicateTypeOpExport op mn (exportedTypeOps exps)

202232 return $ exps { exportedTypeOps = typeOps }

203233

204234-- |

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

206236--

207−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

237+exportTypeClass

238+ :: MonadError MultipleErrors m

239+ => Exports

240+ -> ProperName 'ClassName

241+ -> ModuleName

242+ -> m Exports

208243exportTypeClass exps name mn = do

209244 let exTypes = exportedTypes exps

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

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

212− when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

246+ when (any ((== coerceProperName name) . fst . fst) exTypes) $

247+ throwConflictError ClassConflictsWithType name

248+ when (coerceProperName name `elem` exDctors) $

249+ throwConflictError ClassConflictsWithCtor name

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

214251 return $ exps { exportedTypeClasses = classes }

215252

216253-- |

217254-- Safely adds a value to some exports, returning an error if a conflict occurs.

218255--

219−exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

256+exportValue

257+ :: MonadError MultipleErrors m

258+ => Exports

259+ -> Ident

260+ -> ModuleName

261+ -> m Exports

220262exportValue exps name mn = do

221263 values <- addExport DuplicateValueExport name mn (exportedValues exps)

222264 return $ exps { exportedValues = values }

223265

224266-- |

225−-- Adds an entry to a list of exports unless it is already present, in which case an error is

226−-- returned.

267+-- Safely adds a value operator to some exports, returning an error if a

268+-- conflict occurs.

269+--

270+exportValueOp

271+ :: MonadError MultipleErrors m

272+ => Exports

273+ -> OpName 'ValueOpName

274+ -> ModuleName

275+ -> m Exports

276+exportValueOp exps op mn = do

277+ valueOps <- addExport DuplicateValueOpExport op mn (exportedValueOps exps)

278+ return $ exps { exportedValueOps = valueOps }

279+

280+-- |

281+-- Adds an entry to a list of exports unless it is already present, in which

282+-- case an error is returned.

227283--

228−addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

284+addExport

285+ :: (MonadError MultipleErrors m, Eq a)

286+ => (a -> SimpleErrorMessage)

287+ -> a

288+ -> ModuleName

289+ -> [(a, ModuleName)]

290+ -> m [(a, ModuleName)]

229291addExport what name mn exports =

230292 if any (\(name', mn') -> name == name' && mn /= mn') exports

231293 then throwConflictError what name

@@ -234,12 +296,22 @@ addExport what name mn exports =

234296-- |

235297-- Raises an error for when there is more than one definition for something.

236298--

237−throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b

299+throwConflictError

300+ :: MonadError MultipleErrors m

301+ => (a -> SimpleErrorMessage)

302+ -> a

303+ -> m b

238304throwConflictError conflict = throwError . errorMessage . conflict

239305

240−-- Gets the exports for a module, or an error message if the module doesn't exist

241−getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

242−getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

306+-- |

307+-- Gets the exports for a module, or raise an error if the module doesn't exist.

308+--

309+getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports

310+getExports env mn =

311+ maybe

312+ (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn)

313+ (return . envModuleExports)

314+ $ M.lookup mn env

243315

244316-- |

245317-- When reading a value from the imports, check that there are no conflicts in

@@ -249,16 +321,16 @@ checkImportConflicts

249321 :: forall m a

250322 . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)

251323 => ModuleName

252− -> (a -> String)

324+ -> (a -> Name)

253325 -> [ImportRecord a]

254326 -> m (ModuleName, ModuleName)

255−checkImportConflicts currentModule render xs =

327+checkImportConflicts currentModule toName xs =

256328 let

257329 byOrig = sortBy (compare `on` importSourceModule) xs

258330 groups = groupBy ((==) `on` importSourceModule) byOrig

259331 nonImplicit = filter ((/= FromImplicit) . importProvenance) xs

260− name = render' (importName . head $ xs)

261− conflictModules = map (getQual . importName . head) groups

332+ name = toName . disqualify . importName $ head xs

333+ conflictModules = mapMaybe (getQual . importName . head) groups

262334 in

263335 if length groups > 1

264336 then case nonImplicit of

@@ -270,9 +342,3 @@ checkImportConflicts currentModule render xs =

270342 else

271343 let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig

272344 in return (mnNew, mnOrig)

273− where

274− getQual :: Qualified a -> ModuleName

275− getQual (Qualified (Just mn) _) = mn

276− getQual _ = internalError "unexpected unqualified name in checkImportConflicts"

277− render' :: Qualified a -> String

278− render' (Qualified _ a) = render a

src/Language/PureScript/Sugar/Names/Exports.hs+104−119

@@ -18,7 +18,8 @@ import Language.PureScript.AST

1818import Language.PureScript.Crash

1919import Language.PureScript.Errors

2020import Language.PureScript.Names

21−import Language.PureScript.Sugar.Names.Env

21+import Language.PureScript.Sugar.Names.Env

22+import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)

2223

2324-- |

2425-- Finds all exportable members of a module, disregarding any explicit exports.

@@ -39,8 +40,8 @@ findExportable (Module _ _ mn ds _) =

3940 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

4041 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

4142 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

42− updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn

43− updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

43+ updateExports exps (ValueFixityDeclaration _ _ op) = exportValueOp exps op mn

44+ updateExports exps (TypeFixityDeclaration _ _ op) = exportTypeOp exps op mn

4445 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

4546 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

4647 updateExports exps _ = return exps

@@ -49,62 +50,59 @@ findExportable (Module _ _ mn ds _) =

4950-- Resolves the exports for a module, filtering out members that have not been

5051-- exported and elaborating re-exports of other modules.

5152--

52−resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

53−resolveExports env mn imps exps refs =

54− rethrow (addHint (ErrorInModule mn)) $ do

53+resolveExports

54+ :: forall m

55+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

56+ => Env

57+ -> SourceSpan

58+ -> ModuleName

59+ -> Imports

60+ -> Exports

61+ -> [DeclarationRef]

62+ -> m Exports

63+resolveExports env ss mn imps exps refs =

64+ warnAndRethrow (addHint (ErrorInModule mn)) $ do

5565 filtered <- filterModule mn exps refs

56− let (dupeRefs, dupeDctors) = findDuplicateRefs refs

57− warnDupeRefs dupeRefs

58− warnDupeDctors dupeDctors

59− foldM elaborateModuleExports filtered refs

60−

66+ exps' <- foldM elaborateModuleExports filtered refs

67+ warnDuplicateRefs ss DuplicateExportRef refs

68+ return exps'

69+

6170 where

6271

63− warnDupeRefs :: [DeclarationRef] -> m ()

64− warnDupeRefs = traverse_ $ \case

65− TypeRef name _ -> warnDupe $ "type " ++ runProperName name

66− TypeOpRef name -> warnDupe $ "type operator " ++ runIdent name

67− ValueRef name -> warnDupe $ "value " ++ runIdent name

68− TypeClassRef name -> warnDupe $ "class " ++ runProperName name

69− ModuleRef name -> warnDupe $ "module " ++ runModuleName name

70− _ -> return ()

71−

72− warnDupeDctors :: [ProperName 'ConstructorName] -> m ()

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

74−

75− warnDupe :: String -> m ()

76− warnDupe ref = tell . errorMessage $ DuplicateExportRef ref

77−

7872 -- Takes the current module's imports, the accumulated list of exports, and a

7973 -- `DeclarationRef` for an explicit export. When the ref refers to another

8074 -- module, export anything from the imports that matches for that module.

8175 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

8276 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

83− rethrowWithPosition pos $ elaborateModuleExports result r

77+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r

8478 elaborateModuleExports result (ModuleRef name) | name == mn = do

8579 let types' = exportedTypes result ++ exportedTypes exps

8680 let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

8781 let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

8882 let values' = exportedValues result ++ exportedValues exps

83+ let valueOps' = exportedValueOps result ++ exportedValueOps exps

8984 return result

9085 { exportedTypes = types'

9186 , exportedTypeOps = typeOps'

9287 , exportedTypeClasses = classes'

9388 , exportedValues = values'

89+ , exportedValueOps = valueOps'

9490 }

9591 elaborateModuleExports result (ModuleRef name) = do

9692 let isPseudo = isPseudoModule name

97− when (not isPseudo && not (isImportedModule name)) $

98− throwError . errorMessage . UnknownExportModule $ name

99− reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

100− reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps)

101− reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

102− reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

103− reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

104− result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

105− result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps)

106− result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses)

107− foldM (uncurry . exportValue) result''' (map resolveValue reValues)

93+ when (not isPseudo && not (isImportedModule name))

94+ . throwError . errorMessage . UnknownExport $ ModName name

95+ reTypes <- extract isPseudo name TyName (importedTypes imps)

96+ reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps)

97+ reDctors <- extract isPseudo name DctorName (importedDataConstructors imps)

98+ reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)

99+ reValues <- extract isPseudo name IdentName (importedValues imps)

100+ reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)

101+ foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

102+ >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)

103+ >>= flip (foldM (uncurry . exportTypeClass)) (map resolveClass reClasses)

104+ >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)

105+ >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)

108106 elaborateModuleExports result _ = return result

109107

110108 -- Extracts a list of values for a module based on a lookup table. If the

@@ -113,14 +111,14 @@ resolveExports env mn imps exps refs =

113111 :: (Show a, Ord a)

114112 => Bool

115113 -> ModuleName

116− -> (a -> String)

114+ -> (a -> Name)

117115 -> M.Map (Qualified a) [ImportRecord a]

118116 -> m [Qualified a]

119− extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList

117+ extract useQual name toName = fmap (map (importName . head . snd)) . go . M.toList

120118 where

121119 go = filterM $ \(name', options) -> do

122120 let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options

123− when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options

121+ when (isMatch && length options > 1) $ void $ checkImportConflicts mn toName options

124122 return isMatch

125123 checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir)

126124

@@ -139,6 +137,7 @@ resolveExports env mn imps exps refs =

139137 || any (isQualifiedWith mn') (f (importedDataConstructors imps))

140138 || any (isQualifiedWith mn') (f (importedTypeClasses imps))

141139 || any (isQualifiedWith mn') (f (importedValues imps))

140+ || any (isQualifiedWith mn') (f (importedValueOps imps))

142141

143142 -- Check whether a module name refers to a module that has been imported

144143 -- without qualification into an import scope.

@@ -165,21 +164,35 @@ resolveExports env mn imps exps refs =

165164

166165 -- Looks up an imported type operator and re-qualifies it with the original

167166 -- module it came from.

168− resolveTypeOp :: Qualified Ident -> (Ident, ModuleName)

169− resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

170− resolve exportedTypeOps ident

167+ resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName)

168+ resolveTypeOp op

169+ = splitQual

170+ . fromMaybe (internalError "Missing value in resolveValue")

171+ $ resolve exportedTypeOps op

171172

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

173174 -- came from.

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

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

176− resolve exportedTypeClasses className

176+ resolveClass className

177+ = splitQual

178+ . fromMaybe (internalError "Missing value in resolveClass")

179+ $ resolve exportedTypeClasses className

177180

178181 -- Looks up an imported value and re-qualifies it with the original module it

179182 -- came from.

180183 resolveValue :: Qualified Ident -> (Ident, ModuleName)

181− resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

182− resolve exportedValues ident

184+ resolveValue ident

185+ = splitQual

186+ . fromMaybe (internalError "Missing value in resolveValue")

187+ $ resolve exportedValues ident

188+

189+ -- Looks up an imported operator and re-qualifies it with the original

190+ -- module it came from.

191+ resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ModuleName)

192+ resolveValueOp op

193+ = splitQual

194+ . fromMaybe (internalError "Missing value in resolveValueOp")

195+ $ resolve exportedValueOps op

183196

184197 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

185198 resolve f (Qualified (Just mn'') a) = do

@@ -200,97 +213,69 @@ resolveExports env mn imps exps refs =

200213--

201214filterModule

202215 :: forall m

203− . (MonadError MultipleErrors m)

216+ . MonadError MultipleErrors m

204217 => ModuleName

205218 -> Exports

206219 -> [DeclarationRef]

207220 -> m Exports

208221filterModule mn exps refs = do

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

210− typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs

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

212− classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs

213− return $ exps

222+ types <- foldM filterTypes [] refs

223+ typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs

224+ classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) [] refs

225+ values <- foldM (filterExport IdentName getValueRef exportedValues) [] refs

226+ valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) [] refs

227+ return Exports

214228 { exportedTypes = types

215229 , exportedTypeOps = typeOps

216230 , exportedTypeClasses = classes

217231 , exportedValues = values

232+ , exportedValueOps = valueOps

218233 }

219234

220235 where

221236

222− -- Takes a list of all the exportable types with their data constructors, the

223− -- accumulated list of filtered exports, and a `DeclarationRef` for an

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

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

226− -- result.

227237 filterTypes

228238 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

229− -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

230239 -> DeclarationRef

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

232− filterTypes exps' result (PositionedDeclarationRef pos _ r) =

233− rethrowWithPosition pos $ filterTypes exps' result r

234− filterTypes exps' result (TypeRef name expDcons) =

235− case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of

236− Nothing -> throwError . errorMessage . UnknownExportType $ name

241+ filterTypes result (PositionedDeclarationRef pos _ r) =

242+ rethrowWithPosition pos $ filterTypes result r

243+ filterTypes result (TypeRef name expDcons) =

244+ case matchType `find` exportedTypes exps of

245+ Nothing -> throwError . errorMessage . UnknownExport $ TyName name

237246 Just ((_, dcons), _) -> do

238247 let expDcons' = fromMaybe dcons expDcons

239248 traverse_ (checkDcon name dcons) expDcons'

240249 return $ ((name, expDcons'), mn) : result

241− filterTypes _ result _ = return result

242−

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

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

245− -- the data constructor to check.

246− checkDcon

247− :: ProperName 'TypeName

248− -> [ProperName 'ConstructorName]

249− -> ProperName 'ConstructorName

250− -> m ()

251− checkDcon tcon exps' name =

252− unless (name `elem` exps') $

253− throwError . errorMessage $ UnknownExportDataConstructor tcon name

254−

255− -- Takes a list of all the exportable type operators, the accumulated list of

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

257− -- ref refers to a value in the list of exportable values, the value is

258− -- included in the result.

259− filterTypeOps :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]

260− filterTypeOps exps' result (PositionedDeclarationRef pos _ r) =

261− rethrowWithPosition pos $ filterTypeOps exps' result r

262− filterTypeOps exps' result (TypeOpRef name) =

263− if (name, mn) `elem` exps'

264− then return $ (name, mn) : result

265− else throwError . errorMessage . UnknownExportTypeOp $ name

266− filterTypeOps _ result _ = return result

250+ where

251+ -- Finds a type declaration by matching its name and defining module

252+ matchType ((name', _), mn') = name == name' && mn == mn'

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

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

255+ -- the data constructor to check.

256+ checkDcon

257+ :: ProperName 'TypeName

258+ -> [ProperName 'ConstructorName]

259+ -> ProperName 'ConstructorName

260+ -> m ()

261+ checkDcon tcon dcons dcon =

262+ unless (dcon `elem` dcons) $

263+ throwError . errorMessage $ UnknownExportDataConstructor tcon dcon

264+ filterTypes result _ = return result

267265

268− -- Takes a list of all the exportable classes, the accumulated list of

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

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

271− -- included in the result.

272− filterClasses

273− :: [(ProperName 'ClassName, ModuleName)]

274− -> [(ProperName 'ClassName, ModuleName)]

266+ filterExport

267+ :: Eq a

268+ => (a -> Name)

269+ -> (DeclarationRef -> Maybe a)

270+ -> (Exports -> [(a, ModuleName)])

271+ -> [(a, ModuleName)]

275272 -> DeclarationRef

276− -> m [(ProperName 'ClassName, ModuleName)]

277− filterClasses exps' result (PositionedDeclarationRef pos _ r) =

278− rethrowWithPosition pos $ filterClasses exps' result r

279− filterClasses exps' result (TypeClassRef name) =

280− if (name, mn) `elem` exps'

281− then return $ (name, mn) : result

282− else throwError . errorMessage . UnknownExportTypeClass $ name

283− filterClasses _ result _ = return result

284−

285− -- Takes a list of all the exportable values, the accumulated list of filtered

286− -- exports, and a `DeclarationRef` for an explicit export. When the ref refers

287− -- to a value in the list of exportable values, the value is included in the

288− -- result.

289− filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]

290− filterValues exps' result (PositionedDeclarationRef pos _ r) =

291− rethrowWithPosition pos $ filterValues exps' result r

292− filterValues exps' result (ValueRef name) =

293− if (name, mn) `elem` exps'

294− then return $ (name, mn) : result

295− else throwError . errorMessage . UnknownExportValue $ name

296− filterValues _ result _ = return result

273+ -> m [(a, ModuleName)]

274+ filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

275+ rethrowWithPosition pos $ filterExport toName get fromExps result r

276+ filterExport toName get fromExps result ref

277+ | Just name <- get ref =

278+ if (name, mn) `elem` fromExps exps

279+ then return $ (name, mn) : result

280+ else throwError . errorMessage . UnknownExport $ toName name

281+ filterExport _ _ _ result _ = return result

src/Language/PureScript/Sugar/Names/Imports.hs+66−122

@@ -1,5 +1,6 @@

11module Language.PureScript.Sugar.Names.Imports

2− ( resolveImports

2+ ( ImportDef

3+ , resolveImports

34 , resolveModuleImport

45 , findImports

56 ) where

@@ -9,13 +10,10 @@ import Prelude.Compat

910import Control.Arrow (first)

1011import Control.Monad

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

12−import Control.Monad.Writer (MonadWriter(..))

1313

14−import Data.Foldable (traverse_, for_)

15−import Data.Function (on)

16−import Data.List (find, sortBy, groupBy, (\\))

17−import Data.Maybe (fromMaybe, isNothing)

18−import Data.Traversable (for)

14+import Data.Foldable (for_, traverse_)

15+import Data.List (find)

16+import Data.Maybe (fromMaybe)

1917import qualified Data.Map as M

2018import qualified Data.Set as S

2119

@@ -25,110 +23,44 @@ import Language.PureScript.Errors

2523import Language.PureScript.Names

2624import Language.PureScript.Sugar.Names.Env

2725

26+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

27+

2828-- |

2929-- Finds the imports within a module, mapping the imported module name to an optional set of

3030-- explicitly imported declarations.

3131--

3232findImports

33− :: forall m

34− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

35− => [Declaration]

36− -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

37−findImports = foldM (go Nothing) M.empty

33+ :: [Declaration]

34+ -> M.Map ModuleName [ImportDef]

35+findImports = foldl (go Nothing) M.empty

3836 where

39− go pos result (ImportDeclaration mn typ qual) = do

37+ go pos result (ImportDeclaration mn typ qual) =

4038 let imp = (pos, typ, qual)

41− return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

42− go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d

43− go _ result _ = return result

44−

45−type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

39+ in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

40+ go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d

41+ go _ result _ = result

4642

4743-- |

4844-- Constructs a set of imports for a module.

4945--

5046resolveImports

5147 :: forall m

52− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

48+ . MonadError MultipleErrors m

5349 => Env

5450 -> Module

5551 -> m (Module, Imports)

5652resolveImports env (Module ss coms currentModule decls exps) =

57− warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

58−

59− imports <- findImports decls

60−

61− for_ (M.toList imports) $ \(mn, imps) -> do

62−

63− warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps)

64−

65− let unwarned = imps \\ warned

66− duplicates

67− = join

68− . map tail

69− . filter ((> 1) . length)

70− . groupBy ((==) `on` defQual)

71− . sortBy (compare `on` defQual)

72− $ unwarned

73−

74− warned' <-

75− for duplicates $ \i@(pos, _, _) -> do

76− warn pos $ DuplicateSelectiveImport mn

77− return i

78−

79− for_ (imps \\ (warned ++ warned')) $ \(pos, typ, _) ->

80− let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of

81− Explicit refs -> refs

82− Hiding refs -> refs

83− _ -> []

84− in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors

85−

86− return ()

87−

88− let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports

53+ rethrow (addHint (ErrorInModule currentModule)) $ do

54+ let imports = findImports decls

55+ imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports

8956 scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'

90− resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

91−

92− return (Module ss coms currentModule decls exps, resolved)

93−

94− where

95− defQual :: ImportDef -> Maybe ModuleName

96− defQual (_, _, q) = q

97−

98− selfCartesianSubset :: [a] -> [(a, a)]

99− selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs

100− selfCartesianSubset [] = []

101−

102− checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]

103− checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

104− if (t1 == t2 && q1 == q2)

105− then do

106− warn pos $ DuplicateImport mn t2 q2

107− return $ (pos, t2, q2) : xs

108− else return xs

109−

110− warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()

111− warnDupeRefs pos = traverse_ $ \case

112− TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name

113− TypeOpRef name -> warnDupe pos $ "type operator " ++ runIdent name

114− ValueRef name -> warnDupe pos $ "value " ++ runIdent name

115− TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name

116− ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

117− _ -> return ()

118−

119− warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()

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

121−

122− warnDupe :: Maybe SourceSpan -> String -> m ()

123− warnDupe pos ref = warn pos $ DuplicateImportRef ref

124−

125− warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()

126− warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg

57+ (Module ss coms currentModule decls exps,) <$>

58+ foldM (resolveModuleImport env) nullImports (M.toList scope)

12759

12860-- | Constructs a set of imports for a single module import.

12961resolveModuleImport

13062 :: forall m

131− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

63+ . MonadError MultipleErrors m

13264 => Env

13365 -> Imports

13466 -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])

@@ -139,7 +71,11 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

13971 -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)

14072 -> m Imports

14173 go ie' (pos, typ, impQual) = do

142− modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

74+ modExports <-

75+ positioned $ maybe

76+ (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn)

77+ (return . envModuleExports)

78+ (mn `M.lookup` env)

14379 let virtualModules = importedVirtualModules ie'

14480 ie'' = ie' { importedModules = S.insert mn (importedModules ie')

14581 , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

@@ -155,7 +91,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

15591--

15692resolveImport

15793 :: forall m

158− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

94+ . MonadError MultipleErrors m

15995 => ModuleName

16096 -> Exports

16197 -> Imports

@@ -166,19 +102,14 @@ resolveImport importModule exps imps impQual = resolveByType

166102 where

167103

168104 resolveByType :: Maybe ImportDeclarationType -> m Imports

169− resolveByType Nothing = importAll (importRef Local)

170− resolveByType (Just Implicit) = importAll (importRef FromImplicit)

171− resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs

172− resolveByType (Just (Hiding refs)) = do

173− imps' <- checkRefs True refs >> importAll (importNonHidden refs)

174− let isEmptyImport

175− = M.null (importedTypes imps')

176− && M.null (importedTypeOps imps')

177− && M.null (importedDataConstructors imps')

178− && M.null (importedTypeClasses imps')

179− && M.null (importedValues imps')

180− when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule

181− return imps'

105+ resolveByType Nothing =

106+ importAll (importRef Local)

107+ resolveByType (Just Implicit) =

108+ importAll (importRef FromImplicit)

109+ resolveByType (Just (Explicit refs)) =

110+ checkRefs False refs >> foldM (importRef FromExplicit) imps refs

111+ resolveByType (Just (Hiding refs)) =

112+ checkRefs True refs >> importAll (importNonHidden refs)

182113

183114 -- Check that a 'DeclarationRef' refers to an importable symbol

184115 checkRefs :: Bool -> [DeclarationRef] -> m ()

@@ -187,15 +118,17 @@ resolveImport importModule exps imps impQual = resolveByType

187118 check (PositionedDeclarationRef pos _ r) =

188119 rethrowWithPosition pos $ check r

189120 check (ValueRef name) =

190− checkImportExists UnknownImportValue (fst `map` exportedValues exps) name

121+ checkImportExists IdentName (fst `map` exportedValues exps) name

122+ check (ValueOpRef op) =

123+ checkImportExists ValOpName (fst `map` exportedValueOps exps) op

191124 check (TypeRef name dctors) = do

192− checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name

125+ checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name

193126 let allDctors = fst `map` allExportedDataConstructors name

194− maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors

127+ for_ dctors $ traverse_ (checkDctorExists name allDctors)

195128 check (TypeOpRef name) =

196− checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name

129+ checkImportExists TyOpName (fst `map` exportedTypeOps exps) name

197130 check (TypeClassRef name) =

198− checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

131+ checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name

199132 check (ModuleRef name) | isHiding =

200133 throwError . errorMessage $ ImportHidingModule name

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

@@ -203,12 +136,14 @@ resolveImport importModule exps imps impQual = resolveByType

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

204137 checkImportExists

205138 :: Eq a

206− => (ModuleName -> a -> SimpleErrorMessage)

139+ => (a -> Name)

207140 -> [a]

208141 -> a

209142 -> m ()

210− checkImportExists unknown exports item =

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

143+ checkImportExists toName exports item

144+ = when (item `notElem` exports)

145+ . throwError . errorMessage

146+ $ UnknownImport importModule (toName item)

212147

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

214149 -- from

@@ -217,7 +152,10 @@ resolveImport importModule exps imps impQual = resolveByType

217152 -> [ProperName 'ConstructorName]

218153 -> ProperName 'ConstructorName

219154 -> m ()

220− checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

155+ checkDctorExists tcon exports dctor

156+ = when (dctor `notElem` exports)

157+ . throwError . errorMessage

158+ $ UnknownImportDataConstructor importModule tcon dctor

221159

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

223161 importNonHidden hidden m ref | isHidden ref = return m

@@ -238,18 +176,22 @@ resolveImport importModule exps imps impQual = resolveByType

238176

239177 -- Import all symbols

240178 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

241− importAll importer = do

242− imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

243− imp'' <- foldM (\m (name, _) -> importer m (TypeOpRef name)) imp' (exportedTypeOps exps)

244− imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps)

245− foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps)

179+ importAll importer =

180+ foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

181+ >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps)

182+ >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps)

183+ >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps)

184+ >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps)

246185

247186 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

248187 importRef prov imp (PositionedDeclarationRef pos _ r) =

249− warnAndRethrowWithPosition pos $ importRef prov imp r

188+ rethrowWithPosition pos $ importRef prov imp r

250189 importRef prov imp (ValueRef name) = do

251190 let values' = updateImports (importedValues imp) (exportedValues exps) name prov

252191 return $ imp { importedValues = values' }

192+ importRef prov imp (ValueOpRef name) = do

193+ let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) name prov

194+ return $ imp { importedValueOps = valueOps' }

253195 importRef prov imp (TypeRef name dctors) = do

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

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

@@ -257,7 +199,6 @@ resolveImport importModule exps imps impQual = resolveByType

257199 dctorNames :: [ProperName 'ConstructorName]

258200 dctorNames = fst `map` exportedDctors

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

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

261202 let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

262203 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

263204 importRef prov imp (TypeOpRef name) = do

@@ -266,10 +207,13 @@ resolveImport importModule exps imps impQual = resolveByType

266207 importRef prov imp (TypeClassRef name) = do

267208 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

268209 return $ imp { importedTypeClasses = typeClasses' }

269− importRef _ _ _ = internalError "Invalid argument to importRef"

210+ importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

211+ importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

270212

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

272− allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

214+ allExportedDataConstructors

215+ :: ProperName 'TypeName

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

273217 allExportedDataConstructors name =

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

275219 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/Operators.hs+191−86

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

66-- it is necessary to reorder them here.

77--

88module Language.PureScript.Sugar.Operators

9− ( rebracket

10− , removeSignedLiterals

9+ ( desugarSignedLiterals

10+ , rebracket

11+ , checkFixityExports

1112 ) where

1213

1314import Prelude.Compat

@@ -23,27 +24,43 @@ import Language.PureScript.Sugar.Operators.Types

2324import Language.PureScript.Traversals (defS, sndM)

2425import Language.PureScript.Types

2526

26−import Control.Monad ((<=<))

27+import Control.Monad (unless, (<=<))

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

2829

30+import Data.Either (partitionEithers)

31+import Data.Foldable (for_, traverse_)

2932import Data.Function (on)

30−import Data.Functor.Identity

31−import Data.List (partition, groupBy, sortBy)

32−import Data.Maybe (mapMaybe)

33+import Data.Functor.Identity (Identity(..), runIdentity)

34+import Data.List (groupBy, sortBy)

35+import Data.Maybe (mapMaybe, listToMaybe)

36+import Data.Traversable (for)

3337import qualified Data.Map as M

3438

3539import qualified Language.PureScript.Constants as C

3640

37−-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `FixityAlias` no longer needs to be optional

41+-- |

42+-- Removes unary negation operators and replaces them with calls to `negate`.

43+--

44+desugarSignedLiterals :: Module -> Module

45+desugarSignedLiterals (Module ss coms mn ds exts) =

46+ Module ss coms mn (map f' ds) exts

47+ where

48+ (f', _, _) = everywhereOnValues id go id

49+ go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

50+ go other = other

3851

3952-- |

4053-- An operator associated with its declaration position, fixity, and the name

4154-- of the function or data constructor it is an alias for.

4255--

43−type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias))

56+type FixityRecord op alias = (Qualified op, SourceSpan, Fixity, Qualified alias)

57+type ValueFixityRecord = FixityRecord (OpName 'ValueOpName) (Either Ident (ProperName 'ConstructorName))

58+type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName)

4459

4560-- |

46−-- Remove explicit parentheses and reorder binary operator applications

61+-- Remove explicit parentheses and reorder binary operator applications.

62+--

63+-- This pass requires name desugaring and export elaboration to have run first.

4764--

4865rebracket

4966 :: forall m

@@ -51,44 +68,45 @@ rebracket

5168 => [ExternsFile]

5269 -> [Module]

5370 -> m [Module]

54−rebracket externs ms = do

55− let (typeFixities, valueFixities) = partition isTypeFixity $

56− concatMap externsFixities externs ++ concatMap collectFixities ms

71+rebracket externs modules = do

72+ let (valueFixities, typeFixities) =

73+ partitionEithers

74+ $ concatMap externsFixities externs

75+ ++ concatMap collectFixities modules

5776

58− ensureNoDuplicates' $ valueFixities

59− ensureNoDuplicates' $ typeFixities

77+ ensureNoDuplicates' MultipleValueOpFixities valueFixities

78+ ensureNoDuplicates' MultipleTypeOpFixities typeFixities

6079

6180 let valueOpTable = customOperatorTable' valueFixities

62− typeOpTable = customOperatorTable' typeFixities

63− ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms

81+ let valueAliased = M.fromList (map makeLookupEntry valueFixities)

82+ let typeOpTable = customOperatorTable' typeFixities

83+ let typeAliased = M.fromList (map makeLookupEntry typeFixities)

6484

65− let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities)

66− typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities)

67− mapM (renameAliasedOperators valueAliased typeAliased) ms'

85+ for modules

86+ $ renameAliasedOperators valueAliased typeAliased

87+ <=< rebracketModule valueOpTable typeOpTable

6888

6989 where

7090

71− isTypeFixity :: FixityRecord -> Bool

72− -- Nothing case for FixityAlias can only ever be a value fixity, as it's not

73− -- possible to define types with operator names aside through aliasing.

74− -- TODO: This comment is redundant after 0.9.

75− isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True

76− isTypeFixity _ = False

77−

78− ensureNoDuplicates' :: [FixityRecord] -> m ()

79− ensureNoDuplicates' =

80− ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos))

91+ ensureNoDuplicates'

92+ :: Ord op

93+ => (op -> SimpleErrorMessage)

94+ -> [FixityRecord op alias]

95+ -> m ()

96+ ensureNoDuplicates' toError =

97+ ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos))

8198

82− customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]]

83− customOperatorTable' =

84− customOperatorTable . map (\(i, _, f, _) -> (i, f))

99+ customOperatorTable'

100+ :: [FixityRecord op alias]

101+ -> [[(Qualified op, Associativity)]]

102+ customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f))

85103

86− makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias)

87− makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

104+ makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias)

105+ makeLookupEntry (qname, _, _, alias) = (qname, alias)

88106

89107 renameAliasedOperators

90− :: M.Map (Qualified Ident) (Qualified FixityAlias)

91− -> M.Map (Qualified Ident) (Qualified FixityAlias)

108+ :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName)))

109+ -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))

92110 -> Module

93111 -> m Module

94112 renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =

@@ -110,52 +128,51 @@ rebracket externs ms = do

110128

111129 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

112130 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

113− goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of

114− Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias)

115− Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias)

116− _ -> Var name)

131+ goExpr pos (Op op) =

132+ (pos, ) <$> case op `M.lookup` valueAliased of

133+ Just (Qualified mn' (Left alias)) ->

134+ return $ Var (Qualified mn' alias)

135+ Just (Qualified mn' (Right alias)) ->

136+ return $ Constructor (Qualified mn' alias)

137+ Nothing ->

138+ maybe id rethrowWithPosition pos $

139+ throwError . errorMessage . UnknownName $ fmap ValOpName op

117140 goExpr pos other = return (pos, other)

118141

119142 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

120143 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

121− goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of

122− Just (Qualified _ (AliasValue alias)) ->

123− maybe id rethrowWithPosition pos $

124− throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias

125− Just (Qualified mn' (AliasConstructor alias)) ->

126− return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])

127− _ ->

128− maybe id rethrowWithPosition pos $

129− throwError . errorMessage $ UnknownValue name

130− goBinder _ (BinaryNoParensBinder {}) =

144+ goBinder pos (BinaryNoParensBinder (OpBinder op) lhs rhs) =

145+ case op `M.lookup` valueAliased of

146+ Just (Qualified mn' (Left alias)) ->

147+ maybe id rethrowWithPosition pos $

148+ throwError . errorMessage $

149+ InvalidOperatorInBinder op (Qualified mn' alias)

150+ Just (Qualified mn' (Right alias)) ->

151+ return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])

152+ Nothing ->

153+ maybe id rethrowWithPosition pos $

154+ throwError . errorMessage . UnknownName $ fmap ValOpName op

155+ goBinder _ BinaryNoParensBinder{} =

131156 internalError "BinaryNoParensBinder has no OpBinder"

132157 goBinder pos other = return (pos, other)

133158

134159 goType :: Maybe SourceSpan -> Type -> m Type

135− goType pos = everywhereOnTypesM go

160+ goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go

136161 where

137162 go :: Type -> m Type

138− go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of

139− Just (Qualified mn' (AliasType alias)) ->

140− return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs

141− _ ->

142− maybe id rethrowWithPosition pos $

143− throwError . errorMessage $ UnknownTypeOp name

163+ go (BinaryNoParensType (TypeOp op) lhs rhs) =

164+ case op `M.lookup` typeAliased of

165+ Just alias ->

166+ return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs

167+ Nothing ->

168+ throwError . errorMessage $ UnknownName $ fmap TyOpName op

144169 go other = return other

145170

146−removeSignedLiterals :: Module -> Module

147−removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

148− where

149− (f', _, _) = everywhereOnValues id go id

150−

151− go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

152− go other = other

153−

154171rebracketModule

155172 :: forall m

156173 . (MonadError MultipleErrors m)

157− => [[(Qualified Ident, Associativity)]]

158− -> [[(Qualified Ident, Associativity)]]

174+ => [[(Qualified (OpName 'ValueOpName), Associativity)]]

175+ -> [[(Qualified (OpName 'TypeOpName), Associativity)]]

159176 -> Module

160177 -> m Module

161178rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

@@ -167,7 +184,7 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

167184 (goExpr <=< decontextify goExpr')

168185 goBinder

169186

170− (goDecl, goExpr') = updateTypes (\_ -> goType)

187+ (goDecl, goExpr') = updateTypes (const goType)

171188

172189 goExpr :: Expr -> m Expr

173190 goExpr = return . matchExprOperators valueOpTable

@@ -210,40 +227,61 @@ removeParens = f

210227 -> a

211228 decontextify ctxf = snd . runIdentity . ctxf Nothing

212229

213−externsFixities

214− :: ExternsFile

215− -> [FixityRecord]

230+externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]

216231externsFixities ExternsFile{..} =

217− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

218− | ExternsFixity assoc prec op alias <- efFixities

219− ]

232+ map fromFixity efFixities ++ map fromTypeFixity efTypeFixities

233+ where

220234

221−collectFixities :: Module -> [FixityRecord]

235+ fromFixity

236+ :: ExternsFixity

237+ -> Either ValueFixityRecord TypeFixityRecord

238+ fromFixity (ExternsFixity assoc prec op name) =

239+ Left

240+ ( Qualified (Just efModuleName) op

241+ , internalModuleSourceSpan ""

242+ , Fixity assoc prec

243+ , name

244+ )

245+

246+ fromTypeFixity

247+ :: ExternsTypeFixity

248+ -> Either ValueFixityRecord TypeFixityRecord

249+ fromTypeFixity (ExternsTypeFixity assoc prec op name) =

250+ Right

251+ ( Qualified (Just efModuleName) op

252+ , internalModuleSourceSpan ""

253+ , Fixity assoc prec

254+ , name

255+ )

256+

257+collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]

222258collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

223259 where

224− collect :: Declaration -> [FixityRecord]

225− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

226− [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

260+ collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]

261+ collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) =

262+ [Left (Qualified (Just moduleName) op, pos, fixity, name)]

263+ collect (PositionedDeclaration pos _ (TypeFixityDeclaration fixity name op)) =

264+ [Right (Qualified (Just moduleName) op, pos, fixity, name)]

227265 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

228266 collect _ = []

229267

230268ensureNoDuplicates

231− :: MonadError MultipleErrors m

232− => [(Qualified Ident, SourceSpan)]

269+ :: (Ord a, MonadError MultipleErrors m)

270+ => (a -> SimpleErrorMessage)

271+ -> [(Qualified a, SourceSpan)]

233272 -> m ()

234−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

273+ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m

235274 where

236275 go [] = return ()

237276 go [_] = return ()

238− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

277+ go ((x@(Qualified (Just mn) op), _) : (y, pos) : _) | x == y =

239278 rethrow (addHint (ErrorInModule mn)) $

240− rethrowWithPosition pos $

241− throwError . errorMessage $ MultipleFixities name

279+ rethrowWithPosition pos $ throwError . errorMessage $ toError op

242280 go (_ : rest) = go rest

243281

244282customOperatorTable

245− :: [(Qualified Ident, Fixity)]

246− -> [[(Qualified Ident, Associativity)]]

283+ :: [(Qualified op, Fixity)]

284+ -> [[(Qualified op, Associativity)]]

247285customOperatorTable fixities =

248286 let

249287 userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities

@@ -300,3 +338,70 @@ updateTypes goType = (goDecl, goExpr)

300338 ty' <- goType' pos ty

301339 return (pos, TypedValue check v ty')

302340 goExpr pos other = return (pos, other)

341+

342+-- |

343+-- Checks all the fixity exports within a module to ensure that members aliased

344+-- by the operators are also exported from the module.

345+--

346+-- This pass requires name desugaring and export elaboration to have run first.

347+--

348+checkFixityExports

349+ :: forall m

350+ . MonadError MultipleErrors m

351+ => Module

352+ -> m Module

353+checkFixityExports (Module _ _ _ _ Nothing) =

354+ internalError "exports should have been elaborated before checkFixityExports"

355+checkFixityExports m@(Module ss _ mn ds (Just exps)) =

356+ rethrow (addHint (ErrorInModule mn))

357+ $ rethrowWithPosition ss (traverse_ checkRef exps)

358+ *> return m

359+ where

360+

361+ checkRef :: DeclarationRef -> m ()

362+ checkRef (PositionedDeclarationRef pos _ d) =

363+ rethrowWithPosition pos $ checkRef d

364+ checkRef dr@(ValueOpRef op) =

365+ for_ (getValueOpAlias op) $ \case

366+ Left ident ->

367+ unless (ValueRef ident `elem` exps)

368+ . throwError . errorMessage

369+ $ TransitiveExportError dr [ValueRef ident]

370+ Right ctor ->

371+ unless (anyTypeRef (maybe False (elem ctor) . snd))

372+ . throwError . errorMessage

373+ $ TransitiveDctorExportError dr ctor

374+ checkRef dr@(TypeOpRef op) =

375+ for_ (getTypeOpAlias op) $ \ty ->

376+ unless (anyTypeRef ((== ty) . fst))

377+ . throwError . errorMessage

378+ $ TransitiveExportError dr [TypeRef ty Nothing]

379+ checkRef _ = return ()

380+

381+ -- Finds the name associated with a type operator when that type is also

382+ -- defined in the current module.

383+ getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName)

384+ getTypeOpAlias op =

385+ listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds)

386+ where

387+ go (TypeFixity _ (Qualified (Just mn') ident) op')

388+ | mn == mn' && op == op' = Just ident

389+ go _ = Nothing

390+

391+ -- Finds the value or data constructor associated with an operator when that

392+ -- declaration is also in the current module.

393+ getValueOpAlias

394+ :: OpName 'ValueOpName

395+ -> Maybe (Either Ident (ProperName 'ConstructorName))

396+ getValueOpAlias op =

397+ listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds)

398+ where

399+ go (ValueFixity _ (Qualified (Just mn') ident) op')

400+ | mn == mn' && op == op' = Just ident

401+ go _ = Nothing

402+

403+ -- Tests the exported `TypeRef` entries with a predicate.

404+ anyTypeRef

405+ :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool)

406+ -> Bool

407+ anyTypeRef f = any (maybe False f . getTypeRef) exps

src/Language/PureScript/Sugar/Operators/Binders.hs+4−4

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

66import Language.PureScript.Names

77import Language.PureScript.Sugar.Operators.Common

9−matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder

9+matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder

1010matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id

1111 where

1212

@@ -18,9 +18,9 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id

1818 extractOp (BinaryNoParensBinder op l r) = Just (op, l, r)

1919 extractOp _ = Nothing

2020

21− fromOp :: Binder -> Maybe (Qualified Ident)

22− fromOp (OpBinder q@(Qualified _ (Op _))) = Just q

21+ fromOp :: Binder -> Maybe (Qualified (OpName 'ValueOpName))

22+ fromOp (OpBinder q@(Qualified _ (OpName _))) = Just q

2323 fromOp _ = Nothing

2424

25− reapply :: Qualified Ident -> Binder -> Binder -> Binder

25+ reapply :: Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder

2626 reapply = BinaryNoParensBinder . OpBinder

src/Language/PureScript/Sugar/Operators/Common.hs+11−11

@@ -28,36 +28,36 @@ parseValue :: P.Parsec (Chain a) () a

2828parseValue = token (either Just (const Nothing)) P.<?> "expression"

2929

3030parseOp

31− :: (a -> (Maybe (Qualified Ident)))

32− -> P.Parsec (Chain a) () (Qualified Ident)

31+ :: (a -> (Maybe (Qualified (OpName nameType))))

32+ -> P.Parsec (Chain a) () (Qualified (OpName nameType))

3333parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"

3434

3535matchOp

36− :: (a -> (Maybe (Qualified Ident)))

37− -> Qualified Ident

36+ :: (a -> (Maybe (Qualified (OpName nameType))))

37+ -> Qualified (OpName nameType)

3838 -> P.Parsec (Chain a) () ()

3939matchOp fromOp op = do

4040 ident <- parseOp fromOp

4141 guard $ ident == op

4242

4343opTable

44− :: [[(Qualified Ident, Associativity)]]

45− -> (a -> Maybe (Qualified Ident))

46− -> (Qualified Ident -> a -> a -> a)

44+ :: [[(Qualified (OpName nameType), Associativity)]]

45+ -> (a -> Maybe (Qualified (OpName nameType)))

46+ -> (Qualified (OpName nameType) -> a -> a -> a)

4747 -> [[P.Operator (Chain a) () Identity a]]

4848opTable ops fromOp reapply =

4949 map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops

5050 ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]

5151

5252matchOperators

53− :: forall a

53+ :: forall a nameType

5454 . Show a

5555 => (a -> Bool)

5656 -> (a -> Maybe (a, a, a))

57− -> (a -> Maybe (Qualified Ident))

58− -> (Qualified Ident -> a -> a -> a)

57+ -> (a -> Maybe (Qualified (OpName nameType)))

58+ -> (Qualified (OpName nameType) -> a -> a -> a)

5959 -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a)

60− -> [[(Qualified Ident, Associativity)]]

60+ -> [[(Qualified (OpName nameType), Associativity)]]

6161 -> a

6262 -> a

6363matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains

src/Language/PureScript/Sugar/Operators/Expr.hs+6−6

@@ -11,7 +11,7 @@ import Language.PureScript.AST

1111import Language.PureScript.Names

1212import Language.PureScript.Sugar.Operators.Common

1313

14−matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr

14+matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr

1515matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

1616 where

1717

@@ -23,12 +23,12 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

2323 extractOp (BinaryNoParens op l r) = Just (op, l, r)

2424 extractOp _ = Nothing

2525

26− fromOp :: Expr -> Maybe (Qualified Ident)

27− fromOp (Var q@(Qualified _ (Op _))) = Just q

26+ fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName))

27+ fromOp (Op q@(Qualified _ (OpName _))) = Just q

2828 fromOp _ = Nothing

2929

30− reapply :: Qualified Ident -> Expr -> Expr -> Expr

31− reapply op t1 t2 = App (App (Var op) t1) t2

30+ reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr

31+ reapply op t1 t2 = App (App (Op op) t1) t2

3232

3333 modOpTable

3434 :: [[P.Operator (Chain Expr) () Identity Expr]]

@@ -40,5 +40,5 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

4040 parseTicks :: P.Parsec (Chain Expr) () Expr

4141 parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

4242 where

43− fromOther (Var (Qualified _ (Op _))) = Nothing

43+ fromOther (Op _) = Nothing

4444 fromOther v = Just v

src/Language/PureScript/Sugar/Operators/Types.hs+4−4

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

77import Language.PureScript.Sugar.Operators.Common

88import Language.PureScript.Types

10−matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type

10+matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type

1111matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id

1212 where

1313

@@ -19,9 +19,9 @@ matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id

1919 extractOp (BinaryNoParensType op l r) = Just (op, l, r)

2020 extractOp _ = Nothing

2121

22− fromOp :: Type -> Maybe (Qualified Ident)

23− fromOp (TypeOp q@(Qualified _ (Op _))) = Just q

22+ fromOp :: Type -> Maybe (Qualified (OpName 'TypeOpName))

23+ fromOp (TypeOp q@(Qualified _ (OpName _))) = Just q

2424 fromOp _ = Nothing

2525

26− reapply :: Qualified Ident -> Type -> Type -> Type

26+ reapply :: Qualified (OpName 'TypeOpName) -> Type -> Type -> Type

2727 reapply = BinaryNoParensType . TypeOp

src/Language/PureScript/Sugar/TypeClasses.hs+1−1

@@ -269,7 +269,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

269269

270270 -- Lookup the type arguments and member types for the type class

271271 (args, implies, tyDecls) <-

272− maybe (throwError . errorMessage $ UnknownTypeClass className) return $

272+ maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $

273273 M.lookup (qualify mn className) m

274274

275275 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

src/Language/PureScript/Sugar/TypeDeclarations.hs+23−17

@@ -8,7 +8,6 @@ module Language.PureScript.Sugar.TypeDeclarations

99import Prelude.Compat

1010

11−import Control.Monad (forM)

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

1312

1413import Language.PureScript.AST

@@ -20,38 +19,45 @@ import Language.PureScript.Traversals

2019-- |

2120-- Replace all top level type declarations in a module with type annotations

2221--

23−desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]

24−desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

22+desugarTypeDeclarationsModule

23+ :: forall m

24+ . MonadError MultipleErrors m

25+ => Module

26+ -> m Module

27+desugarTypeDeclarationsModule (Module ss coms name ds exps) =

2528 rethrow (addHint (ErrorInModule name)) $

2629 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

2730 where

2831

2932 desugarTypeDeclarations :: [Declaration] -> m [Declaration]

30− desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

31− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

32− return (PositionedDeclaration pos com d' : ds')

33− desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

33+ desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do

34+ (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest)

35+ return (PositionedDeclaration pos com d' : rest')

36+ desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do

3437 (_, nameKind, val) <- fromValueDeclaration d

35− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

38+ desugarTypeDeclarations (ValueDeclaration name' nameKind [] (Right (TypedValue True val ty)) : rest)

3639 where

3740 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

38− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

41+ fromValueDeclaration (ValueDeclaration name'' nameKind [] (Right val))

42+ | name' == name'' = return (name'', nameKind, val)

3943 fromValueDeclaration (PositionedDeclaration pos com d') = do

4044 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

4145 return (ident, nameKind, PositionedValue pos com val)

42− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

43− desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

44− desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

46+ fromValueDeclaration _ =

47+ throwError . errorMessage $ OrphanTypeDeclaration name'

48+ desugarTypeDeclarations [TypeDeclaration name' _] =

49+ throwError . errorMessage $ OrphanTypeDeclaration name'

50+ desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do

4551 let (_, f, _) = everywhereOnValuesTopDownM return go return

4652 f' (Left gs) = Left <$> mapM (pairM return f) gs

4753 f' (Right v) = Right <$> f v

48− (:) <$> (ValueDeclaration name nameKind bs <$> f' val)

54+ (:) <$> (ValueDeclaration name' nameKind bs <$> f' val)

4955 <*> desugarTypeDeclarations rest

5056 where

51− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

57+ go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val'

5258 go other = return other

53− desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) =

54− (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds)

59+ desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) =

60+ (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds')

5561 <*> desugarTypeDeclarations rest

56− desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

62+ desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest

5763 desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker.hs+17−67

@@ -183,7 +183,7 @@ typeCheckAll

183183 -> [DeclarationRef]

184184 -> [Declaration]

185185 -> m [Declaration]

186−typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

186+typeCheckAll moduleName _ = traverse go

187187 where

188188 go :: Declaration -> m Declaration

189189 go (DataDeclaration dtype name args dctors) = do

@@ -223,7 +223,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

223223 let args' = args `withKinds` kind

224224 addTypeSynonym moduleName name args' ty kind

225225 return $ TypeSynonymDeclaration name args ty

226− go TypeDeclaration{} = internalError "Type declarations should have been removed"

226+ go TypeDeclaration{} =

227+ internalError "Type declarations should have been removed before typeCheckAlld"

227228 go (ValueDeclaration name nameKind [] (Right val)) = do

228229 env <- getEnv

229230 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

@@ -261,9 +262,9 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

261262 Just _ -> throwError . errorMessage $ RedefinedIdent name

262263 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

263264 return d

264− go (d@FixityDeclaration{}) = return d

265− go (d@ImportDeclaration{}) = return d

266− go (d@(TypeClassDeclaration pn args implies tys)) = do

265+ go d@FixityDeclaration{} = return d

266+ go d@ImportDeclaration{} = return d

267+ go d@(TypeClassDeclaration pn args implies tys) = do

267268 addTypeClass moduleName pn args implies tys

268269 return d

269270 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

@@ -277,23 +278,6 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

277278 go (PositionedDeclaration pos com d) =

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

279280

280− checkFixities :: Declaration -> m ()

281− checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do

282− ty <- lookupVariable moduleName (Qualified mn' ident)

283− addValue moduleName (Op name) ty Public

284− checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do

285− env <- getEnv

286− let alias = Qualified mn' ctor

287− case M.lookup alias (dataConstructors env) of

288− Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing

289− Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public

290− checkFixities (FixityDeclaration _ name Nothing) = do

291− env <- getEnv

292− guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

293− checkFixities (PositionedDeclaration pos _ d) =

294− warnAndRethrowWithPosition pos $ checkFixities d

295− checkFixities _ = return ()

296−

297281 checkInstanceMembers :: [Declaration] -> m [Declaration]

298282 checkInstanceMembers instDecls = do

299283 let idents = sort . map head . group . map memberName $ instDecls

@@ -348,16 +332,17 @@ typeCheckModule

348332 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

349333 => Module

350334 -> m Module

351−typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

352−typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

353− modify (\s -> s { checkCurrentModule = Just mn })

354− decls' <- typeCheckAll mn exps decls

355− for_ exps $ \e -> do

356− checkTypesAreExported e

357− checkClassMembersAreExported e

358− checkClassesAreExported e

359− checkNonAliasesAreExported (exportedDataConstructors exps) e

360− return $ Module ss coms mn decls' (Just exps)

335+typeCheckModule (Module _ _ _ _ Nothing) =

336+ internalError "exports should have been elaborated before typeCheckModule"

337+typeCheckModule (Module ss coms mn decls (Just exps)) =

338+ warnAndRethrow (addHint (ErrorInModule mn)) $ do

339+ modify (\s -> s { checkCurrentModule = Just mn })

340+ decls' <- typeCheckAll mn exps decls

341+ for_ exps $ \e -> do

342+ checkTypesAreExported e

343+ checkClassMembersAreExported e

344+ checkClassesAreExported e

345+ return $ Module ss coms mn decls' (Just exps)

361346 where

362347

363348 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()

@@ -436,38 +421,3 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

436421 extractMemberName (TypeDeclaration memberName _) = memberName

437422 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

438423 checkClassMembersAreExported _ = return ()

439−

440− checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()

441− checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =

442− case listToMaybe (mapMaybe (getAlias getValueAlias name) decls) of

443− Just (Left ident) ->

444− unless (ValueRef ident `elem` exps) $

445− throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]

446− Just (Right ctor) ->

447− unless (ctor `elem` exportedDctors) $

448− throwError . errorMessage $ TransitiveDctorExportError dr ctor

449− _ -> return ()

450− checkNonAliasesAreExported _ dr@(TypeOpRef (Op name)) =

451− case listToMaybe (mapMaybe (getAlias getTypeAlias name) decls) of

452− Just ty ->

453− unless (any (isTypeRefFor ty) exps) $

454− throwError . errorMessage $ TransitiveExportError dr [TypeRef ty Nothing]

455− _ -> return ()

456− where

457− isTypeRefFor :: ProperName 'TypeName -> DeclarationRef -> Bool

458− isTypeRefFor ty (TypeRef ty' _) = ty == ty'

459− isTypeRefFor _ _ = False

460− checkNonAliasesAreExported _ _ = return ()

461−

462− getAlias :: (FixityAlias -> Maybe a) -> String -> Declaration -> Maybe a

463− getAlias match name (PositionedDeclaration _ _ d) = getAlias match name d

464− getAlias match name (FixityDeclaration _ name' (Just (Qualified (Just mn') a)))

465− | Just alias <- match a, name == name' && mn == mn' = Just alias

466− getAlias _ _ _ = Nothing

467−

468− exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]

469− exportedDataConstructors = foldMap extractCtor

470− where

471− extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]

472− extractCtor (TypeRef _ (Just ctors)) = ctors

473− extractCtor _ = []

src/Language/PureScript/TypeChecker/Kinds.hs+1−1

@@ -239,7 +239,7 @@ infer' other = (, []) <$> go other

239239 go (TypeConstructor v) = do

240240 env <- getEnv

241241 case M.lookup v (types env) of

242− Nothing -> throwError . errorMessage $ UnknownTypeConstructor v

242+ Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v

243243 Just (kind, _) -> return kind

244244 go (TypeApp t1 t2) = do

245245 k0 <- freshKind

src/Language/PureScript/TypeChecker/Types.hs+3−3

@@ -293,7 +293,7 @@ infer' (Var var) = do

293293infer' v@(Constructor c) = do

294294 env <- getEnv

295295 case M.lookup c (dataConstructors env) of

296− Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

296+ Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

297297 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

298298 return $ TypedValue True v' ty'

299299infer' (Case vals binders) = do

@@ -391,7 +391,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

391391 unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor

392392 unifyTypes ret val

393393 M.unions <$> zipWithM inferBinder (reverse args) binders

394− _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

394+ _ -> throwError . errorMessage . UnknownName . fmap DctorName $ ctor

395395 where

396396 peelArgs :: Type -> ([Type], Type)

397397 peelArgs = go []

@@ -640,7 +640,7 @@ check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop

640640check' v@(Constructor c) ty = do

641641 env <- getEnv

642642 case M.lookup c (dataConstructors env) of

643− Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

643+ Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

644644 Just (_, _, ty1, _) -> do

645645 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

646646 mv <- subsumes (Just v) repl ty

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

@@ -49,7 +49,7 @@ data Type

4949 -- A type operator. This will be desugared into a type constructor during the

5050 -- "operators" phase of desugaring.

5151 --

52− | TypeOp (Qualified Ident)

52+ | TypeOp (Qualified (OpName 'TypeOpName))

5353 -- |

5454 -- A type application

5555 --

@@ -78,7 +78,6 @@ data Type

7878 -- A type with a kind annotation

7979 --

8080 | KindedType Type Kind

81− --

8281 -- |

8382 -- A placeholder used in pretty printing

8483 --

tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs+1−1

@@ -16,7 +16,7 @@ setup = do

1616 Integration.deleteOutputFolder

1717 s <- Integration.compileTestProject

1818 unless s $ fail "Failed to compile .purs sources"

19− Integration.quitServer -- kill a eventually running psc-ide-server instance

19+ -- Integration.quitServer -- kill a eventually running psc-ide-server instance

2020 _ <- Integration.startServer

2121 mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"]

2222

tests/Language/PureScript/Ide/ImportsSpec.hs+3−1

@@ -69,6 +69,8 @@ spec = do

6969 let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i

7070 addValueImport i mn is =

7171 prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is)

72+ addOpImport op mn is =

73+ prettyPrintImportSection (addExplicitImport' (FixityDeclaration op) mn is)

7274 addDtorImport i t mn is =

7375 prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is)

7476 it "adds an implicit unqualified import" $

@@ -96,7 +98,7 @@ spec = do

9698 ]

9799 it "adds an operator to an explicit import list" $

98100 shouldBe

99− (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)

101+ (addOpImport (Left (P.OpName "<~>")) (P.moduleNameFromString "Data.Array") explicitImports)

100102 [ "import Prelude"

101103 , "import Data.Array ((<~>), tail)"

102104 ]

tests/TestDocs.hs−5

@@ -270,11 +270,6 @@ testCases =

270270 , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"

271271 ])

272272

273− -- Remove this after 0.9.

274− , ("OldOperators",

275− [ ShouldBeDocumented (n "OldOperators2") "(>>)" []

276− ])

277−

278273 , ("NewOperators",

279274 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

280275 ])