bb3127b · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'upstream/0.9' into pure11-0.9

commitbb3127b657ccfc05394954491105d107c941b2ed authorAndy Arvanitis <andyarvanitis@gmail.com> dateWed 11 May 2016, 19:55 (10 years ago) parent843a542 f7114e3

83 files changed+1560−1379

compare with golang

unifiedsplit

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/InferRecFunWithConstrainedArgument.purs+1−1

@@ -7,5 +7,5 @@ test 100.0 = 100.0

77test n = test(1.0 + n)

99main = do

10− logShow $ test 0.0

10+ logShow (test 0)

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

psci/PSCi.hs+11−8

@@ -13,7 +13,7 @@ import Prelude ()

1313import Prelude.Compat

1414

1515import Data.Foldable (traverse_)

16−import Data.List (intercalate, nub, sort, find)

16+import Data.List (intercalate, nub, sort, find, foldl')

1717import Data.Tuple (swap)

1818import qualified Data.Map as M

1919

@@ -127,13 +127,15 @@ makeIO f io = do

127127 either (throwError . P.singleError . f) return e

128128

129129make :: PSCiState -> [P.Module] -> P.Make P.Environment

130−make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)

130+make st@PSCiState{..} ms = do

131+ externs <- P.make actions' (map snd loadedModules ++ ms)

132+ return $ foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs

131133 where

132− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules

133− actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False

134− actions' = actions { P.progress = const (return ()) }

135− loadedModules = psciLoadedModules st

136− allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

134+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules

135+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False

136+ actions' = actions { P.progress = const (return ()) }

137+ loadedModules = psciLoadedModules st

138+ allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

137139

138140

139141-- Commands

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

253255

254256 showRef :: P.DeclarationRef -> String

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

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

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

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

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

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

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

260263 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

@@ -210,9 +210,10 @@ library

210210 Language.PureScript.Sugar.CaseDeclarations

211211 Language.PureScript.Sugar.DoNotation

212212 Language.PureScript.Sugar.Names

213+ Language.PureScript.Sugar.Names.Common

213214 Language.PureScript.Sugar.Names.Env

214− Language.PureScript.Sugar.Names.Imports

215215 Language.PureScript.Sugar.Names.Exports

216+ Language.PureScript.Sugar.Names.Imports

216217 Language.PureScript.Sugar.ObjectWildcards

217218 Language.PureScript.Sugar.Operators

218219 Language.PureScript.Sugar.Operators.Common

src/Language/PureScript.hs+1

@@ -16,6 +16,7 @@ import Language.PureScript.Comments as P

1616import Language.PureScript.Crash as P

1717import Language.PureScript.Environment as P

1818import Language.PureScript.Errors as P hiding (indent)

19+import Language.PureScript.Externs as P

1920import Language.PureScript.Kinds as P

2021import Language.PureScript.Linter as P

2122import Language.PureScript.Make as P

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+27−20

@@ -41,10 +41,9 @@ import Language.PureScript.Ide.Types

4141import Language.PureScript.Ide.Util

4242

4343import qualified Language.PureScript as P

44−import qualified Language.PureScript.Externs as PE

4544

4645readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

47− FilePath -> m PE.ExternsFile

46+ FilePath -> m P.ExternsFile

4847readExternFile fp = do

4948 parseResult <- liftIO (decodeStrict <$> BS.readFile fp)

5049 case parseResult of

@@ -57,15 +56,15 @@ moduleNameToText = T.pack . P.runModuleName

5756identToText :: P.Ident -> Text

5857identToText = T.pack . P.runIdent

5958

60−convertExterns :: PE.ExternsFile -> Module

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

59+convertExterns :: P.ExternsFile -> Module

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

6261 where

63− moduleName = moduleNameToText (PE.efModuleName ef)

64− importDecls = convertImport <$> PE.efImports ef

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

68− otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)

62+ moduleName = moduleNameToText (P.efModuleName ef)

63+ importDecls = convertImport <$> P.efImports ef

64+ exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef)

65+ operatorDecls = convertOperator <$> P.efFixities ef

66+ tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef

67+ otherDecls = mapMaybe convertDecl (P.efDeclarations ef)

6968

7069 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)

7170 decls = nub $ appEndo typeClassFilter otherDecls

@@ -81,26 +80,34 @@ isTypeClassDeclaration :: ExternDecl -> Bool

8180isTypeClassDeclaration TypeClassDeclaration{} = True

8281isTypeClassDeclaration _ = False

8382

84−convertImport :: PE.ExternsImport -> ExternDecl

83+convertImport :: P.ExternsImport -> ExternDecl

8584convertImport ei = Dependency

86− (moduleNameToText (PE.eiModule ei))

85+ (moduleNameToText (P.eiModule ei))

8786 []

88− (moduleNameToText <$> PE.eiImportedAs ei)

87+ (moduleNameToText <$> P.eiImportedAs ei)

8988

9089convertExport :: P.DeclarationRef -> Maybe ExternDecl

9190convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn))

9291convertExport _ = Nothing

9392

94−convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl

95−convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind

96−convertDecl PE.EDTypeSynonym{..} = Just $

93+convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl

94+convertDecl P.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind

95+convertDecl P.EDTypeSynonym{..} = Just $

9796 TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType

98−convertDecl PE.EDDataConstructor{..} = Just $

97+convertDecl P.EDDataConstructor{..} = Just $

9998 DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType

100−convertDecl PE.EDValue{..} = Just $

99+convertDecl P.EDValue{..} = Just $

101100 ValueDeclaration (identToText edValueName) edValueType

102−convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName

103−convertDecl PE.EDInstance{} = Nothing

101+convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName

102+convertDecl P.EDInstance{} = Nothing

103+

104+convertOperator :: P.ExternsFixity -> ExternDecl

105+convertOperator P.ExternsFixity{..} =

106+ FixityDeclaration (Left efOperator)

107+

108+convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl

109+convertTypeOperator P.ExternsTypeFixity{..} =

110+ FixityDeclaration (Right efTypeOperator)

104111

105112unwrapPositioned :: P.Declaration -> P.Declaration

106113unwrapPositioned (P.PositionedDeclaration _ _ 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/Rebuild.hs+1−2

@@ -19,7 +19,6 @@ import Data.Maybe (fromJust, mapMaybe)

1919import qualified Data.Set as S

2020import qualified Language.PureScript as P

2121import Language.PureScript.Errors.JSON

22−import qualified Language.PureScript.Externs as P

2322import System.FilePath (replaceExtension)

2423import System.Directory (doesFileExist)

2524import System.IO.UTF8 (readUTF8File)

@@ -54,7 +53,7 @@ rebuildFile path = do

5453 (result, warnings) <- liftIO

5554 . P.runMake P.defaultOptions

5655 . P.rebuildModule (ma { P.progress = const (pure ()) }) externs

57− $ P.addDefaultImport (P.ModuleName [P.ProperName "Prim"]) m

56+ $ m

5857 case result of

5958 Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors

6059 Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings

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

@@ -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(..))

@@ -147,9 +146,10 @@ rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options

147146rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

148147 progress $ CompilingModule moduleName

149148 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

150− lint m

149+ withPrim = importPrim m

150+ lint withPrim

151151 ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do

152− [desugared] <- desugar externs [m]

152+ [desugared] <- desugar externs [withPrim]

153153 runCheck' env $ typeCheckModule desugared

154154 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

155155 let mod' = Module ss coms moduleName regrouped exps

@@ -168,7 +168,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

168168make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

169169 => MakeActions m

170170 -> [Module]

171− -> m Environment

171+ -> m [ExternsFile]

172172make ma@MakeActions{..} ms = do

173173 checkModuleNamesAreUnique

174174

@@ -188,7 +188,7 @@ make ma@MakeActions{..} ms = do

188188

189189 -- Bundle up all the externs and return them as an Environment

190190 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)

191− return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

191+ return externs

192192

193193 where

194194 checkModuleNamesAreUnique :: m ()

@@ -361,7 +361,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

361361 genSourceMap dir mapFile extraLines mappings = do

362362 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)

363363 sourceFile = case mappings of

364− ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file

364+ (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file

365365 _ -> Nothing

366366 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

367367 map (\(SMap _ orig gen) -> Mapping {

@@ -450,11 +450,10 @@ checkForeignDecls m path = do

450450 (errs, _) ->

451451 Left errs

452452

453− -- TODO: Handling for parenthesised operators should be removed after 0.9.

454453 -- We ignore the error message here, just being told it's an invalid

455454 -- identifier should be enough.

456455 parseIdent :: String -> Either String Ident

457− parseIdent str = try str <|> try ("(" ++ str ++ ")")

456+ parseIdent str = try str

458457 where

459458 try s = either (const (Left str)) Right $ do

460459 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/TestCompiler.hs+35−18

@@ -57,7 +57,7 @@ main = hspec spec

5757spec :: Spec

5858spec = do

5959

60− (supportPurs, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do

60+ (supportExterns, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do

6161 cwd <- getCurrentDirectory

6262 let passing = cwd </> "examples" </> "passing"

6363 let failing = cwd </> "examples" </> "failing"

@@ -67,13 +67,20 @@ spec = do

6767 failingFiles <- getTestFiles failing <$> testGlob failing

6868 supportPurs <- supportFiles "purs"

6969 supportForeigns <- loadForeigns =<< supportFiles "js"

70− return (supportPurs, supportForeigns, passingFiles, failingFiles)

70+ supportPursFiles <- readInput supportPurs

71+ supportExterns <- runExceptT $ do

72+ modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

73+ externs <- ExceptT . runTest $ P.make (makeActions supportForeigns) (map snd modules)

74+ return (zip (map snd modules) externs)

75+ case supportExterns of

76+ Left errs -> fail (P.prettyPrintMultipleErrors False errs)

77+ Right externs -> return (externs, supportForeigns, passingFiles, failingFiles)

7178

7279 context ("Passing examples") $ do

7380 forM_ passingTestCases $ \(testPurs, testJS) ->

7481 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do

7582 testForeigns <- loadForeigns testJS

76− assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns)

83+ assertCompiles supportExterns testPurs (supportForeigns <> testForeigns)

7784

7885 context ("Failing examples") $ do

7986 forM_ failingTestCases $ \(testPurs, testJS) -> do

@@ -81,7 +88,7 @@ spec = do

8188 expectedFailures <- runIO $ getShouldFailWith mainPath

8289 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do

8390 testForeigns <- loadForeigns testJS

84− assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures

91+ assertDoesNotCompile supportExterns testPurs (supportForeigns <> testForeigns) expectedFailures

8592

8693 where

8794

@@ -166,27 +173,36 @@ runTest :: P.Make a -> IO (Either P.MultipleErrors a)

166173runTest = fmap fst . P.runMake P.defaultOptions

167174

168175compile

169− :: [FilePath]

176+ :: [(P.Module, P.ExternsFile)]

177+ -> [FilePath]

170178 -> M.Map P.ModuleName FilePath

171− -> IO (Either P.MultipleErrors P.Environment)

172−compile inputFiles foreigns = silence $ runTest $ do

179+ -> IO (Either P.MultipleErrors [P.ExternsFile])

180+compile supportExterns inputFiles foreigns = silence $ runTest $ do

173181 fs <- liftIO $ readInput inputFiles

174182 ms <- P.parseModulesFromFiles id fs

175− P.make (makeActions foreigns) (map snd ms)

183+ let actions = makeActions foreigns

184+ case ms of

185+ [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)

186+ _ -> P.make actions (map fst supportExterns ++ map snd ms)

176187

177188assert

178− :: [FilePath]

189+ :: [(P.Module, P.ExternsFile)]

190+ -> [FilePath]

179191 -> M.Map P.ModuleName FilePath

180− -> (Either P.MultipleErrors P.Environment -> IO (Maybe String))

192+ -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String))

181193 -> Expectation

182−assert inputFiles foreigns f = do

183− e <- compile inputFiles foreigns

194+assert supportExterns inputFiles foreigns f = do

195+ e <- compile supportExterns inputFiles foreigns

184196 maybeErr <- f e

185197 maybe (return ()) expectationFailure maybeErr

186198

187−assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation

188−assertCompiles inputFiles foreigns = do

189− assert inputFiles foreigns $ \e ->

199+assertCompiles

200+ :: [(P.Module, P.ExternsFile)]

201+ -> [FilePath]

202+ -> M.Map P.ModuleName FilePath

203+ -> Expectation

204+assertCompiles supportExterns inputFiles foreigns = do

205+ assert supportExterns inputFiles foreigns $ \e ->

190206 case e of

191207 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs

192208 Right _ -> do

@@ -203,12 +219,13 @@ assertCompiles inputFiles foreigns = do

203219 Nothing -> return $ Just "Couldn't find node.js executable"

204220

205221assertDoesNotCompile

206− :: [FilePath]

222+ :: [(P.Module, P.ExternsFile)]

223+ -> [FilePath]

207224 -> M.Map P.ModuleName FilePath

208225 -> [String]

209226 -> Expectation

210−assertDoesNotCompile inputFiles foreigns shouldFailWith = do

211− assert inputFiles foreigns $ \e ->

227+assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = do

228+ assert supportExterns inputFiles foreigns $ \e ->

212229 case e of

213230 Left errs -> do

214231 return $ if null shouldFailWith

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