3ad48f1 · rowtype-yoga/purescript-native

CONTRIBUTORS.md+1

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

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

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

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

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

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

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

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

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

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

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

examples/docs/src/OldOperators.pursdeleted−10

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

1−

2−-- Remove this after 0.9.

3−module OldOperators (module OldOperators2) where

4−

5−import OldOperators2

6−

7−module OldOperators2 where

8−

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

10−(>>) a b = b

examples/failing/1733.purs+1−1

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

1−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

2module Main where

3

4import Thingy as Thing

examples/failing/1825.purs+4−4

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

1−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

2

3module Main where

4

5data W = X | Y | Z

6

7−bad X a = a

7+bad X a = a

8−bad Y _ = a

8+bad Y _ = a

9−bad Z a = a

9+bad Z a = a

examples/failing/Arrays.purs+2−4

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

1-- @shouldFailWith TypesDoNotUnify

2module Main where

3

4−import Prelude

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

5

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

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

3module M1 (x, y, z) where

4

examples/failing/ExportExplicit1.purs+1−1

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

1−-- @shouldFailWith UnknownDataConstructor

1+-- @shouldFailWith UnknownName

2module Main where

3

4import M1

examples/failing/ExportExplicit3.purs+1−1

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

1−-- @shouldFailWith UnknownDataConstructor

1+-- @shouldFailWith UnknownName

2module Main where

3

4import M1

examples/failing/ImportExplicit.purs+1−1

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

1−-- @shouldFailWith UnknownImportType

1+-- @shouldFailWith UnknownImport

2module Main where

3

4import M1 (X(..))

examples/failing/ImportModule.purs+1−1

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

1−-- @shouldFailWith UnknownModule

1+-- @shouldFailWith UnknownName

2module Main where

3

4import M1

examples/failing/MultipleErrors2.purs+2−2

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

1−-- @shouldFailWith UnknownValue

1+-- @shouldFailWith UnknownName

2−-- @shouldFailWith UnknownValue

2+-- @shouldFailWith UnknownName

3module MultipleErrors2 where

4

5import Prelude

examples/failing/MultipleTypeOpFixities.pursnew file+9

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

1+-- @shouldFailWith MultipleTypeOpFixities

2+module MultipleTypeOpFixities where

3+

4+import Prelude

5+

6+type Op x y = Op x y

7+

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

3+

4+import Prelude

5+

6+add x y = x + y

7+

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

2module Main where

3

4import Prelude

examples/passing/Dollar.purs+3−3

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

2

3import Prelude ()

4

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

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

6−($) f x = f x

6+applyFn f x = f x

7

8−infixr 1000 $

8+infixr 1000 applyFn as $

9

10id x = x

11

examples/passing/Functions.purs+2−5

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

1module Main where

2

3import Prelude

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

4

5

5test1 = \_ -> 0.0

6test1 = \_ -> 0.0

6

7

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

8

9

9test3 = \a -> a

10test3 = \a -> a

10

11

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

12−

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

14−

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

12+main = log "Done"

examples/passing/OperatorSections.purs+3−3

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

12 let foo = { x: 2.0 }

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

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

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

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

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

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

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

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

18 log "Done"

examples/passing/Operators.purs+19−23

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

4import Control.Monad.Eff

5import Control.Monad.Eff.Console

6

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

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

8−(?!) x _ = x

8+op1 x _ = x

9+

10+infix 4 op1 as ?!

9

11

10bar :: String -> String -> String

12bar :: String -> String -> String

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

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

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

21

23

22test4 = 1 `k` 2

24test4 = 1 `k` 2

23

25

24−infixl 5 %%

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

27+op2 x y = x * y + y

25

28

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

29+infixl 5 op2 as %%

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

28

30

29test5 = 1.0 %% 2.0 %% 3.0

31test5 = 1.0 %% 2.0 %% 3.0

30

32

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

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

32

34

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

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

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

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

37+

38+infix 4 op3 as <+>

35

39

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

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

37

41

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

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

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

43+op4 = \f x -> f x

44+

45+infix 4 op4 as @@

40

46

41foo :: String -> String

47foo :: String -> String

42foo = \s -> s

48foo = \s -> s

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

47

53

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

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

49

55

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

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

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

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

52

58

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

59+infix 4 op5 as ...

54

60

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

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

56−

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

58

62

59test14 :: Number -> Number -> Boolean

63test14 :: Number -> Number -> Boolean

60test14 a b = a < b

64test14 a b = a < b

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

71test19 :: Number

75test19 :: Number

72test19 = negate $ negate (-1.0)

76test19 = negate $ negate (-1.0)

73

77

74−test20 :: Number

75−test20 = 1.0 @ 2.0

76− where

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

78−

79main = do

78main = do

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

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

81 let t2 = test2

80 let t2 = test2

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

88 let t9 = test9

87 let t9 = test9

89 let t10 = test10

88 let t10 = test10

90 let t11 = test11

89 let t11 = test11

91− let t12 = test12 k 1.0 2.0

92− let t13 = test13 k 1.0 2.0

93 let t14 = test14 1.0 2.0

90 let t14 = test14 1.0 2.0

94 let t15 = test15 1.0 2.0

91 let t15 = test15 1.0 2.0

95 let t17 = test17

92 let t17 = test17

96 let t18 = test18

93 let t18 = test18

97 let t19 = test19

94 let t19 = test19

98− let t20 = test20

99 log "Done"

95 log "Done"

examples/passing/RebindableSyntax.purs+4−2

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

12 where

13 bind x f = x <> f unit

14

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

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

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

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

17+

18+infixl 4 applySecond as *>

17

19

18newtype Const a b = Const a

20newtype Const a b = Const a

19

21

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

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

1module M1 where

2

3−import Prelude ()

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

4+applyFn f a = f a

4

5

5−($) f a = f a

6−

7−infixr 1000 $

6+infixr 1000 applyFn as $

examples/passing/UnicodeType.purs+4−5

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

1module Main where

2

3import Prelude

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

4

5

5−class (Monad m) ⇐ Monad1 m where

6+class Monad m ⇐ Monad1 m where

6 f1 :: Int

7 f1 :: Int

7

8

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

9+class Monad m <= Monad2 m where

9 f2 :: Int

10 f2 :: Int

10

11

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

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

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

18 n' <- pure n

19 n' <- pure n

19 pure n'

20 pure n'

20

21

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

22−

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

22+main = log "Done"

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

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

35client :: PortID -> IO ()

36client port = do

37 h <-

38− connectTo "localhost" port `catch`

38+ connectTo "127.0.0.1" port `catch`

39 (\(SomeException e) ->

40 putStrLn

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

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

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

39import Language.PureScript.Ide.Error

40import Language.PureScript.Ide.Types

41import Language.PureScript.Ide.Watcher

42−import Network hiding (socketPort)

42+import Network hiding (socketPort, accept)

43import Network.BSD (getProtocolNumber)

44import Network.Socket hiding (PortNumber, Type,

45− accept, sClose)

45+ sClose)

46import Options.Applicative

47import System.Directory

48import System.FilePath

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

166 pure (cmd, h)

167 where

168 acceptConnection = liftIO $ do

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

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

170+ (s,_) <- accept sock

171+ h <- socketToHandle s ReadWriteMode

170 hSetEncoding h utf8

172 hSetEncoding h utf8

171 hSetBuffering h LineBuffering

173 hSetBuffering h LineBuffering

172 pure h

174 pure h

psci/PSCi.hs+2−1

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

253

254 showRef :: P.DeclarationRef -> String

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

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

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

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

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

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

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

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

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

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

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

psci/PSCi/Message.hs+2−3

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

1module PSCi.Message where

2

3−

4import Data.List (intercalate)

3import Data.List (intercalate)

5−import qualified PSCi.Directive as D

4+

6import PSCi.Types

5import PSCi.Types

6+import qualified PSCi.Directive as D

7

8-- Messages

9

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

50--

51quitMessage :: String

52quitMessage = "See ya!"

53−

purescript.cabal+2−1

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

194 Language.PureScript.Sugar.CaseDeclarations

195 Language.PureScript.Sugar.DoNotation

196 Language.PureScript.Sugar.Names

197+ Language.PureScript.Sugar.Names.Common

197 Language.PureScript.Sugar.Names.Env

198 Language.PureScript.Sugar.Names.Env

198− Language.PureScript.Sugar.Names.Imports

199 Language.PureScript.Sugar.Names.Exports

200+ Language.PureScript.Sugar.Names.Imports

200 Language.PureScript.Sugar.ObjectWildcards

201 Language.PureScript.Sugar.ObjectWildcards

201 Language.PureScript.Sugar.Operators

202 Language.PureScript.Sugar.Operators

202 Language.PureScript.Sugar.Operators.Common

203 Language.PureScript.Sugar.Operators.Common

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

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

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

36 -- this data constructor will be removed.

37 --

38− | OpBinder (Qualified Ident)

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

39 -- |

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

41 -- this data constructor will be removed.

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

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

10import Control.Monad.Identity

11

12import Data.Aeson.TH

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

14−import Data.Maybe (mapMaybe)

15import qualified Data.Map as M

13import qualified Data.Map as M

16

14

17import Language.PureScript.AST.Binders

15import Language.PureScript.AST.Binders

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

60 -- |

58 -- |

61 -- A type operator

59 -- A type operator

62 --

60 --

63− | TypeOpRef Ident

61+ | TypeOpRef (OpName 'TypeOpName)

64 -- |

62 -- |

65 -- A value

63 -- A value

66 --

64 --

67 | ValueRef Ident

65 | ValueRef Ident

68 -- |

66 -- |

67+ -- A value-level operator

68+ --

69+ | ValueOpRef (OpName 'ValueOpName)

70+ -- |

69 -- A type class

71 -- A type class

70 --

72 --

71 | TypeClassRef (ProperName 'ClassName)

73 | TypeClassRef (ProperName 'ClassName)

72− -- |

74+ -- |

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

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

74 --

76 --

75 | TypeInstanceRef Ident

77 | TypeInstanceRef Ident

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

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

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

88 (TypeOpRef name) == (TypeOpRef name') = name == name'

90 (TypeOpRef name) == (TypeOpRef name') = name == name'

89 (ValueRef name) == (ValueRef name') = name == name'

91 (ValueRef name) == (ValueRef name') = name == name'

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

90 (TypeClassRef name) == (TypeClassRef name') = name == name'

93 (TypeClassRef name) == (TypeClassRef name') = name == name'

91 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

94 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

92 (ModuleRef name) == (ModuleRef name') = name == name'

95 (ModuleRef name) == (ModuleRef name') = name == name'

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

94 r == (PositionedDeclarationRef _ _ r') = r == r'

97 r == (PositionedDeclarationRef _ _ r') = r == r'

95 _ == _ = False

98 _ == _ = False

96

99

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+

97isModuleRef :: DeclarationRef -> Bool

125isModuleRef :: DeclarationRef -> Bool

98isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

126isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

99isModuleRef (ModuleRef _) = True

127isModuleRef (ModuleRef _) = True

100isModuleRef _ = False

128isModuleRef _ = False

101

129

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−

124-- |

130-- |

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

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

126--

132--

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

184 --

190 --

185 | ExternDataDeclaration (ProperName 'TypeName) Kind

191 | ExternDataDeclaration (ProperName 'TypeName) Kind

186 -- |

192 -- |

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

193+ -- A fixity declaration

188 --

194 --

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

195+ | FixityDeclaration (Either ValueFixity TypeFixity)

190 -- |

196 -- |

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

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

192 --

198 --

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

206 | PositionedDeclaration SourceSpan [Comment] Declaration

212 | PositionedDeclaration SourceSpan [Comment] Declaration

207 deriving (Show, Read)

213 deriving (Show, Read)

208

214

209−data FixityAlias

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

210− = AliasValue Ident

211− | AliasConstructor (ProperName 'ConstructorName)

212− | AliasType (ProperName 'TypeName)

213 deriving (Eq, Ord, Show, Read)

216 deriving (Eq, Ord, Show, Read)

214

217

215−foldFixityAlias

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

216− :: (Ident -> a)

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

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

220+

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

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

219− -> FixityAlias

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

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

233

223

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

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

235data TypeInstanceBody

225data TypeInstanceBody

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

288isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d

278isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d

289isFixityDecl _ = False

279isFixityDecl _ = False

290

280

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

282+getFixityDecl (FixityDeclaration fixity) = Just fixity

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

284+getFixityDecl _ = Nothing

285+

291-- |

286-- |

292-- Test if a declaration is a foreign import

287-- Test if a declaration is a foreign import

293--

288--

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

376 --

371 --

377 | Var (Qualified Ident)

372 | Var (Qualified Ident)

378 -- |

373 -- |

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

375+ -- phase of desugaring.

376+ --

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

378+ -- |

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

380 --

381 | IfThenElse Expr Expr Expr

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

473

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

475$(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

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

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

129 where

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

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

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

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

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

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

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

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

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

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

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

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

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

137−

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

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

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

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−

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

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

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

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

144 matches _ _ = False

141 matches _ _ = False

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

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

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

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

6-- and generates the final Javascript bundle.

7−module Language.PureScript.Bundle (

7+module Language.PureScript.Bundle

8− bundle

8+ ( bundle

9− , ModuleIdentifier(..)

9+ , ModuleIdentifier(..)

10− , moduleName

10+ , moduleName

11− , ModuleType(..)

11+ , ModuleType(..)

12− , ErrorMessage(..)

12+ , ErrorMessage(..)

13− , printErrorMessage

13+ , printErrorMessage

14− , getExportedIdentifiers

14+ , getExportedIdentifiers

15−) where

15+ ) where

16

17import Prelude.Compat

18

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

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

173 --

174 accessor :: Ident -> JS -> JS

175 accessor (Ident prop) = accessorString prop

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

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

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

178

177

179 accessorString :: String -> JS -> JS

178 accessorString :: String -> JS -> JS

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

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

29identToJs (Ident name)

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

31 | otherwise = concatMap identCharToString name

32−identToJs (Op op) = concatMap identCharToString op

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

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

34

33

35-- |

34-- |

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

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

68removeFromBlock _ js = js

69

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

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

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

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

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

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

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

73isFn _ _ = False

75isFn _ _ = False

74

76

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

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

77−

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

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

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

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

80isDict _ _ = False

79isDict _ _ = False

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

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

19import Data.Maybe (fromMaybe)

20

21import Language.PureScript.CodeGen.JS.AST

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

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

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

24−import Language.PureScript.Names

25import qualified Language.PureScript.Constants as C

23import qualified Language.PureScript.Constants as C

26

24

27-- TODO: Potential bug:

25-- TODO: Potential bug:

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

82 where

80 where

83 convert :: JS -> JS

81 convert :: JS -> JS

84 convert (JSApp ss fn [dict])

82 convert (JSApp ss fn [dict])

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

94 convert other = other

92 convert other = other

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

104

102

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

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

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

108 convert :: JS -> JS

106 convert :: JS -> JS

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

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

110 convert other = other

108 convert other = other

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

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

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

113 isOp _ = False

110 isOp _ = False

114

111

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

173 ] ++

170 ] ++

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

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

175 where

172 where

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

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

177 binary dict fns op = everywhereOnJS convert

174 binary dict fns op = everywhereOnJS convert

178 where

175 where

179 convert :: JS -> JS

176 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

181 convert other = other

178 convert other = other

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

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

183 binary' moduleName opString op = everywhereOnJS convert

180 binary' moduleName opString op = everywhereOnJS convert

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

185 convert :: JS -> JS

182 convert :: JS -> JS

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

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

187 convert other = other

184 convert other = other

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

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

189 unary dicts fns op = everywhereOnJS convert

186 unary dicts fns op = everywhereOnJS convert

190 where

187 where

191 convert :: JS -> JS

188 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

193 convert other = other

190 convert other = other

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

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

195 unary' moduleName fnName op = everywhereOnJS convert

192 unary' moduleName fnName op = everywhereOnJS convert

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

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

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

252 convert other = return other

249 convert other = return other

253 isFnCompose :: JS -> JS -> Bool

250 isFnCompose :: JS -> JS -> Bool

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

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

255 isFnComposeFlipped :: JS -> JS -> Bool

252 isFnComposeFlipped :: JS -> JS -> Bool

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

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

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

254+ fnCompose :: (String, String)

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

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

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

256+ fnComposeFlipped :: (String, String)

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

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

261

258

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

259+semiringNumber :: (String, String)

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

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

264

261

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

262+semiringInt :: (String, String)

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

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

267

264

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

265+ringNumber :: (String, String)

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

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

270

267

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

268+ringInt :: (String, String)

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

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

273

270

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

271+euclideanRingNumber :: (String, String)

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

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

276

273

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

274+euclideanRingInt :: (String, String)

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

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

279

276

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

277+eqNumber :: (String, String)

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

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

282

279

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

280+eqInt :: (String, String)

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

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

285

282

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

283+eqString :: (String, String)

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

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

288

285

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

286+eqChar :: (String, String)

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

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

291

288

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

289+eqBoolean :: (String, String)

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

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

294

291

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

292+ordBoolean :: (String, String)

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

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

297

294

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

295+ordNumber :: (String, String)

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

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

300

297

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

298+ordInt :: (String, String)

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

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

303

300

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

301+ordString :: (String, String)

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

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

306

303

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

304+ordChar :: (String, String)

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

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

309

306

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

307+semigroupString :: (String, String)

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

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

312

309

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

310+boundedBoolean :: (String, String)

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

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

315

312

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

313+heytingAlgebraBoolean :: (String, String)

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

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

318

315

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

316+semigroupoidFn :: (String, String)

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

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

321

318

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

319+opAdd :: (String, String)

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

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

324

321

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

322+opMul :: (String, String)

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

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

327

324

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

325+opEq :: (String, String)

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

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

330

327

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

328+opNotEq :: (String, String)

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

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

333

330

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

331+opLessThan :: (String, String)

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

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

336

333

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

334+opLessThanOrEq :: (String, String)

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

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

339

336

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

337+opGreaterThan :: (String, String)

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

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

342

339

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

340+opGreaterThanOrEq :: (String, String)

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

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

345

342

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

343+opAppend :: (String, String)

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

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

348

345

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

346+opSub :: (String, String)

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

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

351

348

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

349+opNegate :: (String, String)

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

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

354

351

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

352+opDiv :: (String, String)

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

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

357

354

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

355+opMod :: (String, String)

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

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

360

357

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

358+opConj :: (String, String)

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

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

363

360

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

361+opDisj :: (String, String)

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

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

366

363

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

364+opNot :: (String, String)

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

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

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

64 isPure _ = False

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

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

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

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

71 isEffFunc _ _ = False

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

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

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

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

72 [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')))]

79 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

73 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

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

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

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

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

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

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

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

205findQualModules decls =

199findQualModules decls =

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

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

207− in f `concatMap` decls

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

208 where

202 where

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

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

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

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

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

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

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

212 fqDecls _ = []

207 fqDecls _ = []

213

208

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

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

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

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

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

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

217 fqValues _ = []

212 fqValues _ = []

218

213

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

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

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

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

221 fqBinders _ = []

216 fqBinders _ = []

222

217

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

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

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

219+ getQual' = maybe [] return . getQual

225− getQual _ = []

226

220

227-- |

221-- |

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

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

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

60 spacer

61

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

63−

64 for_ declComments tell'

62 for_ declComments tell'

65

63

66 unless (null instances) $ do

64 unless (null instances) $ do

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

82 elemAsMarkdown (Keyword x) = x

80 elemAsMarkdown (Keyword x) = x

83 elemAsMarkdown Space = " "

81 elemAsMarkdown Space = " "

84

82

85−fixityAsMarkdown :: P.Fixity -> Docs

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

86−fixityAsMarkdown (P.Fixity associativity precedence) =

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

87− tell' $ concat [ "_"

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

88− , associativityStr

86+-- , associativityStr

89− , " / precedence "

87+-- , " / precedence "

90− , show precedence

88+-- , show precedence

91− , "_"

89+-- , "_"

92− ]

90+-- ]

93− where

91+-- where

94− associativityStr = case associativity of

92+-- associativityStr = case associativity of

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

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

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

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

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

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

98

96

99childToString :: First -> ChildDeclaration -> String

97childToString :: First -> ChildDeclaration -> String

100childToString f decl@ChildDeclaration{..} =

98childToString f decl@ChildDeclaration{..} =

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

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

185 where

186 desugar' =

187 traverse P.desugarDoModule

188− >=> P.desugarCasesModule

188+ >=> traverse P.desugarCasesModule

189− >=> P.desugarTypeDeclarationsModule

189+ >=> traverse P.desugarTypeDeclarationsModule

190 >=> ignoreWarnings . P.desugarImportsWithEnv []

191

192 ignoreWarnings = fmap fst . runWriterT

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

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

35 [P.ModuleName] ->

36 Map P.ModuleName Module ->

37 Map P.ModuleName Module

38−updateReExports env order modules =

38+updateReExports env order = execState action

39− execState action modules

40 where

39 where

41 action =

40 action =

42 void (traverse go order)

41 void (traverse go order)

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

103 P.Exports ->

102 P.Exports ->

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

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

105collectDeclarations imports exports = do

104collectDeclarations imports exports = do

106− valsAndMembers <- collect lookupValueDeclaration impVals expVals

105+ valsAndMembers <- collect lookupValueDeclaration impVals expVals

106+ valOps <- collect lookupValueOpDeclaration impValOps expValOps

107− typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

107+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

108− types <- collect lookupTypeDeclaration impTypes expTypes

108+ types <- collect lookupTypeDeclaration impTypes expTypes

109− typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

109+ typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

110

111 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

112

113 let filteredTypes = filterDataConstructors expCtors types

114 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

115

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

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

117

118 where

119 collect lookup' imps exps = do

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

123 expVals = P.exportedValues exports

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

125

126+ expValOps = P.exportedValueOps exports

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

128+

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

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

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

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

128

131

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

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

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

222 thd (_, _, x) = x

225 thd (_, _, x) = x

223

226

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+

224-- |

241-- |

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

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

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

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

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

242 internalErrorInModule

259 internalErrorInModule

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

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

244

261

245−lookupTypeOpDeclaration ::

262+lookupTypeOpDeclaration

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

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

247− MonadReader P.ModuleName m) =>

248− P.ModuleName ->

264+ => P.ModuleName

249− P.Ident ->

265+ -> P.OpName 'P.TypeOpName

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

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

251lookupTypeOpDeclaration importedFrom tyOp = do

267lookupTypeOpDeclaration importedFrom tyOp = do

252 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

268 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

253 let

269 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

255 case ds of

271 case ds of

256 [d] ->

272 [d] ->

257 pure (importedFrom, [d])

273 pure (importedFrom, [d])

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

259 internalErrorInModule

275 internalErrorInModule

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

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

261

277

262−lookupTypeClassDeclaration ::

278+lookupTypeClassDeclaration

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

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

264− MonadReader P.ModuleName m) =>

265− P.ModuleName ->

280+ => P.ModuleName

266− P.ProperName 'P.ClassName ->

281+ -> P.ProperName 'P.ClassName

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

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

268lookupTypeClassDeclaration importedFrom tyClass = do

283lookupTypeClassDeclaration importedFrom tyClass = do

269 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

284 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

270 let

285 let

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

369--

384--

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

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

371--

386--

372−handleEnv ::

387+handleEnv

373− (MonadReader P.ModuleName m) =>

388+ :: (MonadReader P.ModuleName m)

374− TypeClassEnv ->

389+ => TypeClassEnv

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

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

376handleEnv TypeClassEnv{..} =

391handleEnv TypeClassEnv{..} =

377 envUnhandledMembers

392 envUnhandledMembers

378 |> foldM go (envValues, mkMap envTypeClasses)

393 |> foldM go (envValues, mkMap envTypeClasses)

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

400 , declComments = cdeclComments

415 , declComments = cdeclComments

401 , declSourceSpan = cdeclSourceSpan

416 , declSourceSpan = cdeclSourceSpan

402 , declChildren = []

417 , declChildren = []

403− , declFixity = Nothing

404 , declInfo = ValueDeclaration (addConstraint constraint typ)

418 , declInfo = ValueDeclaration (addConstraint constraint typ)

405 }

419 }

406 _ ->

420 _ ->

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

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

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

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

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

423--

437--

424−filterDataConstructors ::

438+filterDataConstructors

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

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

426− Map P.ModuleName [Declaration] ->

440+ -> Map P.ModuleName [Declaration]

427− Map P.ModuleName [Declaration]

441+ -> Map P.ModuleName [Declaration]

428filterDataConstructors =

442filterDataConstructors =

429 filterExportedChildren isDataConstructor P.runProperName

443 filterExportedChildren isDataConstructor P.runProperName

430

444

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

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

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

434-- the list.

448-- the list.

435--

449--

436−filterTypeClassMembers ::

450+filterTypeClassMembers

437− [P.Ident] ->

451+ :: [P.Ident]

438− Map P.ModuleName [Declaration] ->

452+ -> Map P.ModuleName [Declaration]

439− Map P.ModuleName [Declaration]

453+ -> Map P.ModuleName [Declaration]

440filterTypeClassMembers =

454filterTypeClassMembers =

441 filterExportedChildren isTypeClassMember P.showIdent

455 filterExportedChildren isTypeClassMember P.showIdent

442

456

443−filterExportedChildren ::

457+filterExportedChildren

444− (Functor f) =>

458+ :: (Functor f)

445− (ChildDeclaration -> Bool) ->

459+ => (ChildDeclaration -> Bool)

446− (name -> String) ->

460+ -> (name -> String)

447− [name] ->

461+ -> [name]

448− f [Declaration] ->

462+ -> f [Declaration]

449− f [Declaration]

463+ -> f [Declaration]

450−filterExportedChildren isTargetedKind runName expNames =

464+filterExportedChildren isTargetedKind runName expNames = fmap filterDecls

451− fmap filterDecls

452 where

465 where

453 filterDecls =

466 filterDecls =

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

467+ map $ filterChildren $ \c ->

455− cdeclTitle c `elem` expNames'))

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

456−

457 expNames' = map runName expNames

469 expNames' = map runName expNames

458

470

459allDeclarations :: Module -> [Declaration]

471allDeclarations :: Module -> [Declaration]

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

466internalError :: String -> a

478internalError :: String -> a

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

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

468

480

469−internalErrorInModule ::

481+internalErrorInModule

470− (MonadReader P.ModuleName m) =>

482+ :: (MonadReader P.ModuleName m)

471− String ->

483+ => String

472− m a

484+ -> m a

473internalErrorInModule msg = do

485internalErrorInModule msg = do

474 mn <- ask

486 mn <- ask

475 internalError

487 internalError

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3module Language.PureScript.Docs.Convert.Single

1module Language.PureScript.Docs.Convert.Single

4 ( convertSingleModule

2 ( convertSingleModule

5 , collectBookmarks

3 , collectBookmarks

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

11import Control.Monad

9import Control.Monad

12

10

13import Data.Either

11import Data.Either

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

12+import Data.List (nub)

15−import Data.Maybe (mapMaybe, isNothing)

13+import Data.Maybe (mapMaybe)

16

14

17import Language.PureScript.Docs.Types

15import Language.PureScript.Docs.Types

18import qualified Language.PureScript as P

16import qualified Language.PureScript as P

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

30 P.exportedDeclarations

28 P.exportedDeclarations

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

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

32 >>> augmentDeclarations

30 >>> augmentDeclarations

33− >>> map addDefaultFixity

34

31

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

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

36-- converting.

33-- converting.

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

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

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

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

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

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

59-- 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.

66data DeclarationAugment

60data DeclarationAugment

67 = AugmentChild ChildDeclaration

61 = AugmentChild ChildDeclaration

68− | AugmentFixity P.Fixity

69

62

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

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

71-- the type synonym IntermediateDeclaration for more information.

64-- the type synonym IntermediateDeclaration for more information.

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

79 then augmentWith a d

72 then augmentWith a d

80 else d) ds

73 else d) ds

81

74

82− augmentWith a d =

75+ augmentWith (AugmentChild child) d =

83− case a of

84− AugmentChild child ->

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

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

104

77

105getDeclarationTitle :: P.Declaration -> Maybe String

78getDeclarationTitle :: P.Declaration -> Maybe String

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

116getDeclarationTitle _ = Nothing

89getDeclarationTitle _ = Nothing

117

90

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

122 , declComments = Nothing

95 , declComments = Nothing

123 , declSourceSpan = Nothing

96 , declSourceSpan = Nothing

124 , declChildren = []

97 , declChildren = []

125− , declFixity = Nothing

126 , declInfo = info

98 , declInfo = info

127 }

99 }

128

100

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

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

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

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

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

134 basicDeclaration title (ValueDeclaration ty)

106 basicDeclaration title (ValueDeclaration ty)

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

107+convertDeclaration P.ValueDeclaration{} title =

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

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

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

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

138 basicDeclaration title (ValueDeclaration P.TypeWildcard{})

110 basicDeclaration title (ValueDeclaration P.TypeWildcard{})

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

172

144

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

181 where

153 where

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

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

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

192 augment)

164 augment)

193

165

194− withAugmentChild f (t, a) =

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

195− case a of

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

197− _ -> (t, a)

198convertDeclaration _ _ = Nothing

167convertDeclaration _ _ = Nothing

199

168

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

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

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

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

59 syntax "("

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

61 <> syntax ")" <> sp <> syntax "<="

62+

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

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

63 [ keywordFixity associativity

64 [ keywordFixity associativity

64 , syntax $ show precedence

65 , syntax $ show precedence

65− , ident $ renderAlias for

66+ , ident $ renderQualAlias for

66 , keyword "as"

67 , keyword "as"

67 , ident $ adjustAliasName alias declTitle

68 , ident $ adjustAliasName alias declTitle

68 ]

69 ]

69

70

70 where

71 where

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

71 renderType' = renderTypeWithOptions opts

73 renderType' = renderTypeWithOptions opts

74+

75+ renderQualAlias :: FixityAlias -> String

72− renderAlias (P.Qualified mn alias)

76+ renderQualAlias (P.Qualified mn alias)

73− | mn == currentModule opts =

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

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+ | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias

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

79+

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

80+ renderAlias

80− alias

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

81−

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+

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

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

83 adjustAliasName _ title = tail (init title)

89 adjustAliasName _ title = tail (init title)

84

90

85renderChildDeclaration :: ChildDeclaration -> RenderedCode

91renderChildDeclaration :: ChildDeclaration -> RenderedCode

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

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

49 match (BinaryNoParensType op l r) =

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

51 match (TypeOp (Qualified mn op)) =

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

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

53 match _ =

54 Nothing

55

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

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

14import Data.Aeson ((.=))

15import Data.Aeson.BetterErrors

16import Data.ByteString.Lazy (ByteString)

17+import Data.Either (isLeft, isRight)

17import Data.Maybe (mapMaybe)

18import Data.Maybe (mapMaybe)

18import Data.Text (Text)

19import Data.Text (Text)

19import Data.Version

20import Data.Version

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

84 , declComments :: Maybe String

85 , declComments :: Maybe String

85 , declSourceSpan :: Maybe P.SourceSpan

86 , declSourceSpan :: Maybe P.SourceSpan

86 , declChildren :: [ChildDeclaration]

87 , declChildren :: [ChildDeclaration]

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

88 , declInfo :: DeclarationInfo

89 }

90 deriving (Show, Eq, Ord)

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

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

132 -- operator's fixity.

133 --

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

134+ | AliasDeclaration P.Fixity FixityAlias

135 deriving (Show, Eq, Ord)

136

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

138+

137declInfoToString :: DeclarationInfo -> String

139declInfoToString :: DeclarationInfo -> String

138declInfoToString (ValueDeclaration _) = "value"

140declInfoToString (ValueDeclaration _) = "value"

139declInfoToString (DataDeclaration _ _) = "data"

141declInfoToString (DataDeclaration _ _) = "data"

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

165isValueAlias :: Declaration -> Bool

167isValueAlias :: Declaration -> Bool

166isValueAlias Declaration{..} =

168isValueAlias Declaration{..} =

167 case declInfo of

169 case declInfo of

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

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

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

170 _ -> False

171 _ -> False

171

172

172isTypeAlias :: Declaration -> Bool

173isTypeAlias :: Declaration -> Bool

173isTypeAlias Declaration{..} =

174isTypeAlias Declaration{..} =

174 case declInfo of

175 case declInfo of

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

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

176 _ -> False

177 _ -> False

177

178

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

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

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

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

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

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

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

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

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

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

366 <*> key "info" asDeclarationInfo

367

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

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

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

384 <*> key "precedence" asIntegral

385

386+asFixityAlias :: Parse PackageError FixityAlias

387+asFixityAlias = fromAesonParser

388+

386parseAssociativity :: String -> Maybe P.Associativity

389parseAssociativity :: String -> Maybe P.Associativity

387parseAssociativity str = case str of

390parseAssociativity str = case str of

388 "infix" -> Just P.Infix

391 "infix" -> Just P.Infix

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

411 TypeClassDeclaration <$> key "arguments" asTypeArguments

414 TypeClassDeclaration <$> key "arguments" asTypeArguments

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

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

413 "alias" ->

416 "alias" ->

414− AliasDeclaration <$> key "for" asAliasFor

417+ AliasDeclaration <$> key "fixity" asFixity

415− <*> key "fixity" asFixity

418+ <*> key "alias" asFixityAlias

416 other ->

419 other ->

417 throwCustomError (InvalidDeclarationType other)

420 throwCustomError (InvalidDeclarationType other)

418

421

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

420−asAliasFor = fromAesonParser

421−

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

423asTypeArguments = eachInArray asTypeArgument

424 where

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

537 , "comments" .= declComments

538 , "sourceSpan" .= declSourceSpan

539 , "children" .= declChildren

540− , "fixity" .= declFixity

541 , "info" .= declInfo

540 , "info" .= declInfo

542 ]

541 ]

543

542

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

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

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

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

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

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

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

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

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

562

561

563instance A.ToJSON ChildDeclarationInfo where

562instance A.ToJSON ChildDeclarationInfo where

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

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

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

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

48 | CannotWriteFile FilePath

49 | InfiniteType Type

50 | InfiniteKind Kind

51− | MultipleFixities Ident

51+ | MultipleValueOpFixities (OpName 'ValueOpName)

52+ | MultipleTypeOpFixities (OpName 'TypeOpName)

52 | OrphanTypeDeclaration Ident

53 | OrphanTypeDeclaration Ident

53− | OrphanFixityDeclaration String

54 | RedefinedModule ModuleName [SourceSpan]

55 | RedefinedIdent Ident

56 | OverlappingNamesInLet

57− | UnknownModule ModuleName

57+ | UnknownName (Qualified Name)

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

58+ | UnknownImport ModuleName Name

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

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

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

60+ | UnknownExport Name

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

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

75− | ScopeConflict String [ModuleName]

62+ | ScopeConflict Name [ModuleName]

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

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

77 | ConflictingTypeDecls (ProperName 'TypeName)

64 | ConflictingTypeDecls (ProperName 'TypeName)

78 | ConflictingCtorDecls (ProperName 'ConstructorName)

65 | ConflictingCtorDecls (ProperName 'ConstructorName)

79 | TypeConflictsWithClass (ProperName 'TypeName)

66 | TypeConflictsWithClass (ProperName 'TypeName)

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

83 | DuplicateModuleName ModuleName

70 | DuplicateModuleName ModuleName

84 | DuplicateClassExport (ProperName 'ClassName)

71 | DuplicateClassExport (ProperName 'ClassName)

85 | DuplicateValueExport Ident

72 | DuplicateValueExport Ident

73+ | DuplicateValueOpExport (OpName 'ValueOpName)

86− | DuplicateTypeOpExport Ident

74+ | DuplicateTypeOpExport (OpName 'TypeOpName)

87 | DuplicateTypeArgument String

75 | DuplicateTypeArgument String

88 | InvalidDoBind

76 | InvalidDoBind

89 | InvalidDoLet

77 | InvalidDoLet

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

128 | MissingTypeDeclaration Ident Type

116 | MissingTypeDeclaration Ident Type

129 | OverlappingPattern [[Binder]] Bool

117 | OverlappingPattern [[Binder]] Bool

130 | IncompleteExhaustivityCheck

118 | IncompleteExhaustivityCheck

131− | ClassOperator (ProperName 'ClassName) Ident

132 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

119 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

133 | ImportHidingModule ModuleName

120 | ImportHidingModule ModuleName

134 | UnusedImport ModuleName

121 | UnusedImport ModuleName

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

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

136 | UnusedDctorImport (ProperName 'TypeName)

123 | UnusedDctorImport (ProperName 'TypeName)

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

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

138− | DeprecatedOperatorDecl String

139 | DuplicateSelectiveImport ModuleName

125 | DuplicateSelectiveImport ModuleName

140 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

126 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

141− | DuplicateImportRef String

127+ | DuplicateImportRef Name

142− | DuplicateExportRef String

128+ | DuplicateExportRef Name

143 | IntOutOfRange Integer String Integer Integer

129 | IntOutOfRange Integer String Integer Integer

144 | RedundantEmptyHidingImport ModuleName

130 | RedundantEmptyHidingImport ModuleName

145 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

131 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

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

147 | HidingImport ModuleName [DeclarationRef]

133 | HidingImport ModuleName [DeclarationRef]

148 | CaseBinderLengthDiffers Int [Binder]

134 | CaseBinderLengthDiffers Int [Binder]

149 | IncorrectAnonymousArgument

135 | IncorrectAnonymousArgument

150− | InvalidOperatorInBinder Ident Ident

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

151 | DeprecatedRequirePath

137 | DeprecatedRequirePath

152 | CannotGeneralizeRecursiveFunction Ident Type

138 | CannotGeneralizeRecursiveFunction Ident Type

153 deriving (Show)

139 deriving (Show)

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

232 CannotWriteFile{} -> "CannotWriteFile"

218 CannotWriteFile{} -> "CannotWriteFile"

233 InfiniteType{} -> "InfiniteType"

219 InfiniteType{} -> "InfiniteType"

234 InfiniteKind{} -> "InfiniteKind"

220 InfiniteKind{} -> "InfiniteKind"

235− MultipleFixities{} -> "MultipleFixities"

221+ MultipleValueOpFixities{} -> "MultipleValueOpFixities"

222+ MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"

236 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

223 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

237− OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

238 RedefinedModule{} -> "RedefinedModule"

224 RedefinedModule{} -> "RedefinedModule"

239 RedefinedIdent{} -> "RedefinedIdent"

225 RedefinedIdent{} -> "RedefinedIdent"

240 OverlappingNamesInLet -> "OverlappingNamesInLet"

226 OverlappingNamesInLet -> "OverlappingNamesInLet"

241− UnknownModule{} -> "UnknownModule"

227+ UnknownName{} -> "UnknownName"

242− UnknownType{} -> "UnknownType"

228+ UnknownImport{} -> "UnknownImport"

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"

257 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

229 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

230+ UnknownExport{} -> "UnknownExport"

258 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

231 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

259 ScopeConflict{} -> "ScopeConflict"

232 ScopeConflict{} -> "ScopeConflict"

260 ScopeShadowing{} -> "ScopeShadowing"

233 ScopeShadowing{} -> "ScopeShadowing"

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

267 DuplicateModuleName{} -> "DuplicateModuleName"

240 DuplicateModuleName{} -> "DuplicateModuleName"

268 DuplicateClassExport{} -> "DuplicateClassExport"

241 DuplicateClassExport{} -> "DuplicateClassExport"

269 DuplicateValueExport{} -> "DuplicateValueExport"

242 DuplicateValueExport{} -> "DuplicateValueExport"

243+ DuplicateValueOpExport{} -> "DuplicateValueOpExport"

270 DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"

244 DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"

271 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

245 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

272 InvalidDoBind -> "InvalidDoBind"

246 InvalidDoBind -> "InvalidDoBind"

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

312 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

286 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

313 OverlappingPattern{} -> "OverlappingPattern"

287 OverlappingPattern{} -> "OverlappingPattern"

314 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

288 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

315− ClassOperator{} -> "ClassOperator"

316 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

289 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

317 ImportHidingModule{} -> "ImportHidingModule"

290 ImportHidingModule{} -> "ImportHidingModule"

318 UnusedImport{} -> "UnusedImport"

291 UnusedImport{} -> "UnusedImport"

319 UnusedExplicitImport{} -> "UnusedExplicitImport"

292 UnusedExplicitImport{} -> "UnusedExplicitImport"

320 UnusedDctorImport{} -> "UnusedDctorImport"

293 UnusedDctorImport{} -> "UnusedDctorImport"

321 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

294 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

322− DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

323 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

295 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

324 DuplicateImport{} -> "DuplicateImport"

296 DuplicateImport{} -> "DuplicateImport"

325 DuplicateImportRef{} -> "DuplicateImportRef"

297 DuplicateImportRef{} -> "DuplicateImportRef"

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

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

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

542 , indent . line $ path

514 , indent . line $ path

543 ] ++

515 ] ++

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

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

545 renderSimpleErrorMessage (ErrorParsingModule err) =

517 renderSimpleErrorMessage (ErrorParsingModule err) =

546 paras [ line "Unable to parse module: "

518 paras [ line "Unable to parse module: "

547 , prettyPrintParseError err

519 , prettyPrintParseError err

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

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

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

587 , indent $ line $ prettyPrintKind ki

559 , indent $ line $ prettyPrintKind ki

588 ]

560 ]

589− renderSimpleErrorMessage (MultipleFixities name) =

561+ renderSimpleErrorMessage (MultipleValueOpFixities op) =

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

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

591 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

565 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

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

566 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."

595 renderSimpleErrorMessage (RedefinedModule name filenames) =

567 renderSimpleErrorMessage (RedefinedModule name filenames) =

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

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

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

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

598 ]

570 ]

599 renderSimpleErrorMessage (RedefinedIdent name) =

571 renderSimpleErrorMessage (RedefinedIdent name) =

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

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

601− renderSimpleErrorMessage (UnknownModule mn) =

573+ renderSimpleErrorMessage (UnknownName name) =

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

603− renderSimpleErrorMessage (UnknownType name) =

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

574+ line $ "Unknown " ++ printName name

605− renderSimpleErrorMessage (UnknownTypeOp name) =

575+ renderSimpleErrorMessage (UnknownImport mn 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

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

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

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

618 ]

578 ]

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

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

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

645 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

583 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

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

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

647 renderSimpleErrorMessage (ScopeConflict nm ms) =

585 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:"

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

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

650 ]

588 ]

651 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =

589 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:"

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

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

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

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

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

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

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

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

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

674 renderSimpleErrorMessage (DuplicateValueExport nm) =

612 renderSimpleErrorMessage (DuplicateValueExport nm) =

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

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

676− renderSimpleErrorMessage (DuplicateTypeOpExport nm) =

614+ renderSimpleErrorMessage (DuplicateValueOpExport op) =

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

616+ renderSimpleErrorMessage (DuplicateTypeOpExport op) =

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

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

678 renderSimpleErrorMessage (CycleInDeclaration nm) =

618 renderSimpleErrorMessage (CycleInDeclaration nm) =

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

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

680 renderSimpleErrorMessage (CycleInModules mns) =

620 renderSimpleErrorMessage (CycleInModules mns) =

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

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

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

868 renderSimpleErrorMessage (UnusedTypeVar tv) =

808 renderSimpleErrorMessage (UnusedTypeVar tv) =

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

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

875 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

810 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

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

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

877 renderSimpleErrorMessage (ImportHidingModule name) =

812 renderSimpleErrorMessage (ImportHidingModule name) =

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

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

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

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

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

919

854

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−

927 renderSimpleErrorMessage (DuplicateSelectiveImport name) =

855 renderSimpleErrorMessage (DuplicateSelectiveImport name) =

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

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

929

857

930 renderSimpleErrorMessage (DuplicateImport name imp qual) =

858 renderSimpleErrorMessage (DuplicateImport name imp qual) =

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

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

932

860

933− renderSimpleErrorMessage (DuplicateImportRef ref) =

861+ renderSimpleErrorMessage (DuplicateImportRef name) =

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

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

935

863

936− renderSimpleErrorMessage (DuplicateExportRef ref) =

864+ renderSimpleErrorMessage (DuplicateExportRef name) =

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

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

938

866

939 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

867 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

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

868 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

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

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

970

898

971 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

899 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 ++ "."

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

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

974 ]

902 ]

975

903

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

1099 , detail

1027 , detail

1100 ]

1028 ]

1101

1029

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+

1102 valueDepth :: Int

1048 valueDepth :: Int

1103 valueDepth | full = 1000

1049 valueDepth | full = 1000

1104 | otherwise = 3

1050 | otherwise = 3

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

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

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

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

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

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

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

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

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

1183prettyPrintRef (ValueRef ident) = showIdent ident

1129prettyPrintRef (ValueRef ident) = showIdent ident

1130+prettyPrintRef (ValueOpRef op) = showOp op

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

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

1185prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1132prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

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

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

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

8 ( ExternsFile(..)

9 , ExternsImport(..)

10 , ExternsFixity(..)

11+ , ExternsTypeFixity(..)

11 , ExternsDeclaration(..)

12 , ExternsDeclaration(..)

12 , moduleToExternsFile

13 , moduleToExternsFile

13 , applyExternsFileToEnvironment

14 , applyExternsFileToEnvironment

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

45 , efImports :: [ExternsImport]

46 , efImports :: [ExternsImport]

46 -- | List of operators and their fixities

47 -- | List of operators and their fixities

47 , efFixities :: [ExternsFixity]

48 , efFixities :: [ExternsFixity]

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

50+ , efTypeFixities :: [ExternsTypeFixity]

48 -- | List of type and value declaration

51 -- | List of type and value declaration

49 , efDeclarations :: [ExternsDeclaration]

52 , efDeclarations :: [ExternsDeclaration]

50 } deriving (Show, Read)

53 } deriving (Show, Read)

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

68 -- | The precedence level of the operator

71 -- | The precedence level of the operator

69 , efPrecedence :: Precedence

72 , efPrecedence :: Precedence

70 -- | The operator symbol

73 -- | The operator symbol

71− , efOperator :: String

74+ , efOperator :: OpName 'ValueOpName

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

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

74 } deriving (Show, Read)

90 } deriving (Show, Read)

75

91

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

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

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

147 efExports = exps

163 efExports = exps

148 efImports = mapMaybe importDecl ds

164 efImports = mapMaybe importDecl ds

149 efFixities = mapMaybe fixityDecl ds

165 efFixities = mapMaybe fixityDecl ds

166+ efTypeFixities = mapMaybe typeFixityDecl ds

150 efDeclarations = concatMap toExternsDeclaration efExports

167 efDeclarations = concatMap toExternsDeclaration efExports

151

168

152 fixityDecl :: Declaration -> Maybe ExternsFixity

169 fixityDecl :: Declaration -> Maybe ExternsFixity

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

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

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

171+ fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) 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

161 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

172 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

162 fixityDecl _ = Nothing

173 fixityDecl _ = Nothing

163

174

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+

164 importDecl :: Declaration -> Maybe ExternsImport

184 importDecl :: Declaration -> Maybe ExternsImport

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

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

166 importDecl (PositionedDeclaration _ _ d) = importDecl d

186 importDecl (PositionedDeclaration _ _ d) = importDecl d

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

201

221

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

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

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

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

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

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

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

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

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

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

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

58identToText = T.pack . P.runIdent

59

60convertExterns :: PE.ExternsFile -> Module

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

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

62 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

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

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

68 otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)

69

70 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)

@@ -102,6 +102,14 @@ convertDecl PE.EDValue{..} = Just $

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

103convertDecl PE.EDInstance{} = Nothing

104

105+convertOperator :: PE.ExternsFixity -> ExternDecl

106+convertOperator PE.ExternsFixity{..} =

107+ FixityDeclaration (Left efOperator)

108+

109+convertTypeOperator :: PE.ExternsTypeFixity -> ExternDecl

110+convertTypeOperator PE.ExternsTypeFixity{..} =

111+ FixityDeclaration (Right efTypeOperator)

112+

105unwrapPositioned :: P.Declaration -> P.Declaration

113unwrapPositioned :: P.Declaration -> P.Declaration

106unwrapPositioned (P.PositionedDeclaration _ _ x) = x

114unwrapPositioned (P.PositionedDeclaration _ _ x) = x

107unwrapPositioned x = x

115unwrapPositioned x = x

src/Language/PureScript/Ide/Imports.hs+9−6

@@ -209,15 +209,18 @@ addExplicitImport' decl moduleName imports =

209 then imports

210 else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports

211 where

212− refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n

212+ refFromDeclaration (TypeClassDeclaration n) =

213+ P.TypeClassRef n

213 refFromDeclaration (DataConstructor n tn _) =

214 refFromDeclaration (DataConstructor n tn _) =

214 P.TypeRef tn (Just [P.ProperName (T.unpack n)])

215 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

216 refFromDeclaration d =

222 refFromDeclaration d =

217− let

218− ident = T.unpack (identifierFromExternDecl d)

223+ P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d)

219− in

220− P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident)

221

224

222 -- | Adds a declaration to an import:

225 -- | Adds a declaration to an import:

223 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

226 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

src/Language/PureScript/Ide/Types.hs+1

@@ -61,6 +61,7 @@ data ExternDecl

61 P.Type -- The "type"

62 -- | An exported module

63 | TypeClassDeclaration (P.ProperName 'P.ClassName)

64+ | FixityDeclaration (Either (P.OpName 'P.ValueOpName) (P.OpName 'P.TypeOpName))

64 | Export ModuleIdent -- The exported Modules name

65 | Export ModuleIdent -- The exported Modules name

65 deriving (Show,Eq,Ord)

66 deriving (Show,Eq,Ord)

66

67

src/Language/PureScript/Ide/Util.hs+5

@@ -31,6 +31,9 @@ runProperNameT = T.pack . P.runProperName

31runIdentT :: P.Ident -> Text

32runIdentT = T.pack . P.runIdent

33

34+runOpNameT :: P.OpName a -> Text

35+runOpNameT = T.pack . P.runOpName

36+

34prettyTypeT :: P.Type -> Text

37prettyTypeT :: P.Type -> Text

35prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType

38prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType

36

39

@@ -41,6 +44,8 @@ identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name

41identifierFromExternDecl (DataConstructor name _ _) = name

44identifierFromExternDecl (DataConstructor name _ _) = name

42identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name

45identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name

43identifierFromExternDecl (ModuleDecl name _) = name

46identifierFromExternDecl (ModuleDecl name _) = name

47+identifierFromExternDecl (FixityDeclaration (Left op)) = runOpNameT op

48+identifierFromExternDecl (FixityDeclaration (Right op)) = runOpNameT op

44identifierFromExternDecl Dependency{} = "~Dependency~"

49identifierFromExternDecl Dependency{} = "~Dependency~"

45identifierFromExternDecl Export{} = "~Export~"

50identifierFromExternDecl Export{} = "~Export~"

46

51

src/Language/PureScript/Linter.hs+1−11

@@ -40,7 +40,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

40 lintDeclaration :: Declaration -> m ()

41 lintDeclaration = tell . f

42 where

43− (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo

43+ (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo

44

45 f :: Declaration -> MultipleErrors

46 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

@@ -48,16 +48,6 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

48 f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

49 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

50

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−

61 stepE :: S.Set Ident -> Expr -> MultipleErrors

51 stepE :: S.Set Ident -> Expr -> MultipleErrors

62 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

52 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

63 stepE s (Let ds' _) = foldMap go ds'

53 stepE s (Let ds' _) = foldMap go ds'

src/Language/PureScript/Linter/Imports.hs+164−133

@@ -6,52 +6,32 @@ module Language.PureScript.Linter.Imports

6

7import Prelude.Compat

8

9−import Control.Monad (unless, when)

9+import Control.Monad (join, unless, when, foldM, (<=<))

10−import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Writer.Class

10import Control.Monad.Writer.Class

12

11

13−import Data.Foldable (forM_)

12+import Data.Function (on)

13+import Data.Foldable (for_)

14−import Data.List ((\\), find, intersect, nub)

14+import Data.List (find, intersect, nub, groupBy, sortBy, (\\))

15−import Data.Maybe (mapMaybe)

15+import Data.Maybe (mapMaybe, fromMaybe)

16import Data.Monoid (Sum(..))

17+import Data.Traversable (forM)

17import qualified Data.Map as M

18import qualified Data.Map as M

18

19

19import Language.PureScript.AST.Declarations

20import Language.PureScript.AST.Declarations

20import Language.PureScript.AST.SourcePos

21import Language.PureScript.AST.SourcePos

21import Language.PureScript.Crash

22import Language.PureScript.Crash

22import Language.PureScript.Errors

23import Language.PureScript.Errors

23−import Language.PureScript.Names as P

24+import Language.PureScript.Names

25+import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)

24import Language.PureScript.Sugar.Names.Env

26import Language.PureScript.Sugar.Names.Env

25import Language.PureScript.Sugar.Names.Imports

27import Language.PureScript.Sugar.Names.Imports

26import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

27

29

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

30+-- |

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.

31+-- Map of module name to list of imported names from that module which have

32+-- been used.

33+--

54−type UsedImports = M.Map ModuleName [Name]

34+type UsedImports = M.Map ModuleName [Qualified Name]

55

35

56-- |

36-- |

57-- Find and warn on:

37-- Find and warn on:

@@ -69,46 +49,80 @@ type UsedImports = M.Map ModuleName [Name]

69--

49--

70lintImports

50lintImports

71 :: forall m

51 :: forall m

72− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

52+ . MonadWriter MultipleErrors m

73 => Module

53 => Module

74 -> Env

54 -> Env

75 -> UsedImports

55 -> UsedImports

76 -> m ()

56 -> m ()

57+lintImports (Module _ _ _ _ Nothing) _ _ = return ()

77−lintImports (Module _ _ mn mdecls mexports) env usedImps = do

58+lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do

59+

60+ -- TODO: this needs some work to be easier to understand

78

61

79− let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)

62+ let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env)

80 usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

63 usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

81 numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls

64 numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls

82 allowImplicit = numOpenImports == 1

65 allowImplicit = numOpenImports == 1

66+ imports = M.toAscList (findImports mdecls)

83

67

84− imps <- M.toAscList <$> findImports mdecls

85−

86− forM_ imps $ \(mni, decls) ->

68+ for_ imports $ \(mni, decls) ->

87− unless (isPrim mni) $ do

69+ unless (isPrim mni) $

88− forM_ decls $ \(ss, declType, qualifierName) ->

70+ for_ decls $ \(ss', declType, qualifierName) ->

89− censor (onErrorMessages $ addModuleLocError ss) $ do

71+ maybe id warnWithPosition ss' $ do

90 let names = nub $ M.findWithDefault [] mni usedImps'

72 let names = nub $ M.findWithDefault [] mni usedImps'

91 lintImportDecl env mni qualifierName names declType allowImplicit

73 lintImportDecl env mni qualifierName names declType allowImplicit

92

74

93− forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do

75+ for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do

94 let mnis = nub $ map (\(_, _, mni) -> mni) entries

76 let mnis = nub $ map (\(_, _, mni) -> mni) entries

95 unless (length mnis == 1) $ do

77 unless (length mnis == 1) $ do

96 let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

78 let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

97− forM_ implicits $ \(ss, _, mni) ->

79+ for_ implicits $ \(ss', _, mni) ->

98− censor (onErrorMessages $ addModuleLocError ss) $ do

80+ maybe id warnWithPosition ss' $ do

99 let names = nub $ M.findWithDefault [] mni usedImps'

81 let names = nub $ M.findWithDefault [] mni usedImps'

100 usedRefs = findUsedRefs env mni (Just mnq) names

82 usedRefs = findUsedRefs env mni (Just mnq) names

101 unless (null usedRefs) $

83 unless (null usedRefs) $

102 tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

84 tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

103

85

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

105

110

106 where

111 where

107

112

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+

108 countOpenImports :: Declaration -> Int

120 countOpenImports :: Declaration -> Int

109− countOpenImports (ImportDeclaration mn' Implicit Nothing) | not (isPrim mn') = 1

110− countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) | not (isPrim mn') = 1

111 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

121 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

112 countOpenImports _ = 0

126 countOpenImports _ = 0

113

127

114 -- Checks whether a module is the Prim module - used to suppress any checks

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

125 byQual = foldr goImp M.empty

139 byQual = foldr goImp M.empty

126 where

140 where

127 goImp (mni, xs) acc = foldr (goDecl mni) acc xs

141 goImp (mni, xs) acc = foldr (goDecl mni) acc xs

128− goDecl mni (ss, declType, Just qmn) acc =

142+ goDecl mni (ss', declType, Just qmn) acc =

129− let entry = (ss, declType, mni)

143+ let entry = (ss', declType, mni)

130 in M.alter (Just . maybe [entry] (entry :)) qmn acc

144 in M.alter (Just . maybe [entry] (entry :)) qmn acc

131 goDecl _ _ acc = acc

145 goDecl _ _ acc = acc

132

146

133 -- The list of modules that are being re-exported by the current module. Any

147 -- The list of modules that are being re-exported by the current module. Any

134 -- module that appears in this list is always considered to be used.

148 -- module that appears in this list is always considered to be used.

135 exportedModules :: [ModuleName]

149 exportedModules :: [ModuleName]

136− exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports

150+ exportedModules = nub $ mapMaybe extractModule mexports

137 where

151 where

138 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

152 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

139 extractModule (ModuleRef mne) = Just mne

153 extractModule (ModuleRef mne) = Just mne

@@ -150,46 +164,44 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

150 values = extractByQual mne (importedValues scope) IdentName

164 values = extractByQual mne (importedValues scope) IdentName

151 in foldr go used (classes ++ types ++ dctors ++ values)

165 in foldr go used (classes ++ types ++ dctors ++ values)

152 where

166 where

153− go :: (ModuleName, Name) -> UsedImports -> UsedImports

167+ go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports

154 go (q, name) = M.alter (Just . maybe [name] (name :)) q

168 go (q, name) = M.alter (Just . maybe [name] (name :)) q

155

169

156 extractByQual

170 extractByQual

157 :: (Eq a)

171 :: (Eq a)

158 => ModuleName

172 => ModuleName

159 -> M.Map (Qualified a) [ImportRecord a]

173 -> M.Map (Qualified a) [ImportRecord a]

160− -> (Qualified a -> Name)

174+ -> (a -> Name)

161− -> [(ModuleName, Name)]

175+ -> [(ModuleName, Qualified Name)]

162 extractByQual k m toName = mapMaybe go (M.toList m)

176 extractByQual k m toName = mapMaybe go (M.toList m)

163 where

177 where

164 go (q@(Qualified mnq _), is)

178 go (q@(Qualified mnq _), is)

165 | isUnqualified q =

179 | isUnqualified q =

166 case find (isQualifiedWith k) (map importName is) of

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

168 _ -> Nothing

182 _ -> Nothing

169 | isQualifiedWith k q =

183 | isQualifiedWith k q =

170− case importName (head is) of

184+ case importName (head is) of

171− Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)

185+ Qualified (Just mn') name -> Just (mn', Qualified mnq (toName name))

172− _ -> internalError "unqualified name in extractByQual"

186+ _ -> internalError "unqualified name in extractByQual"

173 go _ = Nothing

187 go _ = Nothing

174

188

175lintImportDecl

189lintImportDecl

176 :: forall m

190 :: forall m

177− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

191+ . MonadWriter MultipleErrors m

178 => Env

192 => Env

179 -> ModuleName

193 -> ModuleName

180 -> Maybe ModuleName

194 -> Maybe ModuleName

181− -> [Name]

195+ -> [Qualified Name]

182 -> ImportDeclarationType

196 -> ImportDeclarationType

183 -> Bool

197 -> Bool

184− -> m ()

198+ -> m Bool

185lintImportDecl env mni qualifierName names declType allowImplicit =

199lintImportDecl env mni qualifierName names declType allowImplicit =

186 case declType of

200 case declType of

187 Implicit -> case qualifierName of

201 Implicit -> case qualifierName of

188− Nothing -> unless allowImplicit (checkImplicit ImplicitImport)

202+ Nothing -> unless' allowImplicit (checkImplicit ImplicitImport)

189− Just q ->

203+ Just q -> unless' (q `elem` mapMaybe getQual names) unused

190− let usedModuleNames = mapMaybe extractQualName names

191− in unless (q `elem` usedModuleNames) unused

192− Hiding _ -> unless allowImplicit (checkImplicit HidingImport)

204+ Hiding _ -> unless' allowImplicit (checkImplicit HidingImport)

193 Explicit [] -> unused

205 Explicit [] -> unused

194 Explicit declrefs -> checkExplicit declrefs

206 Explicit declrefs -> checkExplicit declrefs

195

207

@@ -197,39 +209,48 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

197

209

198 checkImplicit

210 checkImplicit

199 :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)

211 :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)

200− -> m ()

212+ -> m Bool

201 checkImplicit warning =

213 checkImplicit warning =

202 if null allRefs

214 if null allRefs

203 then unused

215 then unused

204− else tell $ errorMessage $ warning mni allRefs

216+ else warn (warning mni allRefs)

205

217

206 checkExplicit

218 checkExplicit

207 :: [DeclarationRef]

219 :: [DeclarationRef]

208− -> m ()

220+ -> m Bool

209 checkExplicit declrefs = do

221 checkExplicit declrefs = do

210 let idents = nub (mapMaybe runDeclRef declrefs)

222 let idents = nub (mapMaybe runDeclRef declrefs)

211− dctors = mapMaybe (matchDctor qualifierName) names

223+ dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names

212− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

224+ usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names

213 diff = idents \\ usedNames

225 diff = idents \\ usedNames

226+

214− case (length diff, length idents) of

227+ didWarn <- case (length diff, length idents) of

215− (0, _) -> return ()

228+ (0, _) -> return False

216 (n, m) | n == m -> unused

229 (n, m) | n == m -> unused

217− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs

230+ _ -> warn (UnusedExplicitImport mni diff qualifierName allRefs)

218

231

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

221 let allCtors = dctorsForType mni tn

233 let allCtors = dctorsForType mni tn

234+ -- If we've not already warned a type is unused, check its data constructors

235+ unless' (runProperName tn `notElem` usedNames) $

222− when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of

236+ case (c, dctors `intersect` allCtors) of

223− (_, []) | c /= Just [] ->

224− tell $ errorMessage $ UnusedDctorImport tn

237+ (_, []) | c /= Just [] -> warn (UnusedDctorImport tn)

225− (Just ctors, dctors') ->

238+ (Just ctors, dctors') ->

226− let ddiff = ctors \\ dctors'

239+ let ddiff = ctors \\ dctors'

227− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

240+ in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff

228− _ -> return ()

241+ _ -> return False

242+

229− return ()

243+ return (didWarn || or didWarn')

230−

244+

231− unused :: m ()

245+ unused :: m Bool

232− unused = tell $ errorMessage $ UnusedImport mni

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

233

254

234 allRefs :: [DeclarationRef]

255 allRefs :: [DeclarationRef]

235 allRefs = findUsedRefs env mni qualifierName names

256 allRefs = findUsedRefs env mni qualifierName names

@@ -244,29 +265,27 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

244 -> ProperName 'TypeName

265 -> ProperName 'TypeName

245 -> [ProperName 'ConstructorName]

266 -> [ProperName 'ConstructorName]

246 dctorsForType mn tn =

267 dctorsForType mn tn =

247− maybe [] getDctors (find matches $ dtys mn)

268+ maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn)

248− where

249− matches ((ty, _),_) = ty == tn

250− getDctors ((_,ctors),_) = ctors

251

269

252 typeForDCtor

270 typeForDCtor

253 :: ModuleName

271 :: ModuleName

254 -> ProperName 'ConstructorName

272 -> ProperName 'ConstructorName

255 -> Maybe (ProperName 'TypeName)

273 -> Maybe (ProperName 'TypeName)

256− typeForDCtor mn pn =

274+ typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn)

257− getTy <$> find matches (dtys mn)

258− where

259− matches ((_, ctors), _) = pn `elem` ctors

260− getTy ((ty, _), _) = ty

261

275

276+findUsedRefs

277+ :: Env

278+ -> ModuleName

262−findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]

279+ -> Maybe ModuleName

280+ -> [Qualified Name]

281+ -> [DeclarationRef]

263−findUsedRefs env mni qualifierName names =

282+findUsedRefs env mni qn names =

264 let

283 let

265− classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

284+ classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names

266− valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

285+ valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names

267− typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names

286+ typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names

268− types = mapMaybe (getTypeName qualifierName) names

287+ types = mapMaybe (getTypeName <=< disqualifyFor qn) names

269− dctors = mapMaybe (matchDctor qualifierName) names

288+ dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names

270 typesWithDctors = reconstructTypeRefs dctors

289 typesWithDctors = reconstructTypeRefs dctors

271 typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

290 typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

272 typesRefs

291 typesRefs

@@ -281,7 +300,8 @@ findUsedRefs env mni qualifierName names =

281 -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

300 -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

282 reconstructTypeRefs = foldr accumDctors M.empty

301 reconstructTypeRefs = foldr accumDctors M.empty

283 where

302 where

303+ accumDctors dctor =

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

304+ M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

285

305

286 findTypeForDctor

306 findTypeForDctor

287 :: ModuleName

307 :: ModuleName

@@ -297,25 +317,13 @@ findUsedRefs env mni qualifierName names =

297

317

298matchName

318matchName

299 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

319 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

300− -> Maybe ModuleName

301 -> Name

320 -> Name

302 -> Maybe String

321 -> Maybe String

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

322+matchName _ (IdentName x) = Just $ showIdent x

304−matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

323+matchName _ (TyName x) = Just $ runProperName x

305−matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

324+matchName _ (TyClassName x) = Just $ runProperName x

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

325+matchName lookupDc (DctorName x) = runProperName <$> lookupDc x

307−matchName _ _ _ = Nothing

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

319

327

320runDeclRef :: DeclarationRef -> Maybe String

328runDeclRef :: DeclarationRef -> Maybe String

321runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

329runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

@@ -324,15 +332,38 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

324runDeclRef (TypeClassRef pn) = Just $ runProperName pn

332runDeclRef (TypeClassRef pn) = Just $ runProperName pn

325runDeclRef _ = Nothing

333runDeclRef _ = Nothing

326

334

327−getTypeRef

335+checkDuplicateImports

328− :: DeclarationRef

336+ :: MonadWriter MultipleErrors m

329− -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

337+ => ModuleName

330−getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

338+ -> [ImportDef]

331−getTypeRef (TypeRef pn x) = Just (pn, x)

339+ -> (ImportDef, ImportDef)

332−getTypeRef _ = Nothing

340+ -> m [ImportDef]

333−

341+checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

334−addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

342+ if t1 == t2 && q1 == q2

335−addModuleLocError sp err =

343+ then do

336− case sp of

344+ maybe id warnWithPosition pos $

337− Just pos -> withPosition pos err

345+ tell $ errorMessage $ DuplicateImport mn t2 q2

338− _ -> err

346+ return $ (pos, t2, q2) : xs

347+ else return xs

348+

349+-- |

350+-- Checks that an import with a hiding reference is not hiding all possible

351+-- imports.

352+--

353+checkEmptyImport

354+ :: MonadWriter MultipleErrors m

355+ => ModuleName

356+ -> Imports

357+ -> ImportDeclarationType

358+ -> m ()

359+checkEmptyImport importModule imps (Hiding _) = do

360+ let isEmptyImport

361+ = M.null (importedTypes imps)

362+ && M.null (importedTypeOps imps)

363+ && M.null (importedDataConstructors imps)

364+ && M.null (importedTypeClasses imps)

365+ && M.null (importedValues imps)

366+ && M.null (importedValueOps imps)

367+ when isEmptyImport . tell . errorMessage $

368+ RedundantEmptyHidingImport importModule

369+checkEmptyImport _ _ _ = return ()

src/Language/PureScript/Make.hs+2−4

@@ -19,7 +19,6 @@ module Language.PureScript.Make

19

20import Prelude.Compat

21

22−import Control.Applicative ((<|>))

23import Control.Concurrent.Lifted as C

22import Control.Concurrent.Lifted as C

24import Control.Monad hiding (sequence)

23import Control.Monad hiding (sequence)

25import Control.Monad.Base (MonadBase(..))

24import Control.Monad.Base (MonadBase(..))

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

361 genSourceMap dir mapFile extraLines mappings = do

360 genSourceMap dir mapFile extraLines mappings = do

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

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

363 sourceFile = case mappings of

362 sourceFile = case mappings of

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

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

365 _ -> Nothing

364 _ -> Nothing

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

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

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

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

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

450 (errs, _) ->

449 (errs, _) ->

451 Left errs

450 Left errs

452

451

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

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

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

455 -- identifier should be enough.

453 -- identifier should be enough.

456 parseIdent :: String -> Either String Ident

454 parseIdent :: String -> Either String Ident

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

455+ parseIdent str = try str

458 where

456 where

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

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

460 ts <- PSParser.lex "" s

458 ts <- PSParser.lex "" s

src/Language/PureScript/ModuleDependencies.hs+6−2

@@ -69,8 +69,8 @@ usedModules ams d =

69 -- Regardless of whether an imported module is qualified we still need to

70 -- take into account its import to build an accurate list of dependencies.

71 [mn]

72− forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _)))

72+ forDecls (FixityDeclaration fd)

73− | mn `notElem` ams = [mn]

73+ | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]

74 forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)

75 | mn `notElem` ams = [mn]

76 forDecls _ = []

@@ -87,6 +87,10 @@ usedModules ams d =

87 | mn `notElem` ams = [mn]

88 forTypes _ = []

89

90+ extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName

91+ extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn

92+ extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn

93+

90-- |

94-- |

91-- Convert a strongly connected component of the module graph to a module

95-- Convert a strongly connected component of the module graph to a module

92--

96--

src/Language/PureScript/Names.hs+75−12

@@ -7,13 +7,51 @@ module Language.PureScript.Names where

7

8import Prelude.Compat

9

10−import Control.Monad (liftM)

11import Control.Monad.Supply.Class

10import Control.Monad.Supply.Class

12

11

13import Data.Aeson

12import Data.Aeson

14import Data.Aeson.TH

13import Data.Aeson.TH

15import Data.List

14import Data.List

16

15

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+

17-- |

55-- |

18-- Names for value identifiers

56-- Names for value identifiers

19--

57--

@@ -23,10 +61,6 @@ data Ident

23 --

61 --

24 = Ident String

62 = Ident String

25 -- |

63 -- |

26− -- A symbolic name for an infix operator

27− --

28− | Op String

29− -- |

30 -- A generated name for an identifier

64 -- A generated name for an identifier

31 --

65 --

32 | GenIdent (Maybe String) Integer

66 | GenIdent (Maybe String) Integer

@@ -34,19 +68,37 @@ data Ident

34

68

35runIdent :: Ident -> String

69runIdent :: Ident -> String

36runIdent (Ident i) = i

70runIdent (Ident i) = i

37−runIdent (Op op) = op

38runIdent (GenIdent Nothing n) = "$" ++ show n

71runIdent (GenIdent Nothing n) = "$" ++ show n

39runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

72runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

40

73

41showIdent :: Ident -> String

74showIdent :: Ident -> String

42−showIdent (Op op) = '(' : op ++ ")"

75+showIdent = runIdent

43−showIdent i = runIdent i

44

76

45−freshIdent :: (MonadSupply m) => String -> m Ident

77+freshIdent :: MonadSupply m => String -> m Ident

46−freshIdent name = liftM (GenIdent (Just name)) fresh

78+freshIdent name = GenIdent (Just name) <$> fresh

47

79

48−freshIdent' :: (MonadSupply m) => m Ident

80+freshIdent' :: MonadSupply m => m Ident

49−freshIdent' = liftM (GenIdent Nothing) fresh

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

50

102

51-- |

103-- |

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

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

@@ -100,6 +152,9 @@ showQualified :: (a -> String) -> Qualified a -> String

100showQualified f (Qualified Nothing a) = f a

152showQualified f (Qualified Nothing a) = f a

101showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

153showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

102

154

155+getQual :: Qualified a -> Maybe ModuleName

156+getQual (Qualified mn _) = mn

157+

103-- |

158-- |

104-- Provide a default module name, if a name is unqualified

159-- Provide a default module name, if a name is unqualified

105--

160--

@@ -117,6 +172,14 @@ mkQualified name mn = Qualified (Just mn) name

117disqualify :: Qualified a -> a

172disqualify :: Qualified a -> a

118disqualify (Qualified _ a) = a

173disqualify (Qualified _ a) = a

119

174

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+

120-- |

183-- |

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

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

122--

185--

src/Language/PureScript/Parser/Common.hs+8−2

@@ -43,10 +43,16 @@ parseQualified parser = part []

43 qual path = if null path then Nothing else Just $ ModuleName path

44

45-- |

46−-- Parse an identifier or parenthesized operator

46+-- Parse an identifier.

47--

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

50

56

51-- |

57-- |

52-- Run the first parser, then match the second if possible, applying the specified function on a successful match

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

42-- |

43-- Read source position information

44--

45+withSourceSpan

46+ :: (SourceSpan -> [Comment] -> a -> a)

45−withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a

47+ -> P.Parsec [PositionedToken] u a

48+ -> P.Parsec [PositionedToken] u a

46withSourceSpan f p = do

49withSourceSpan f p = do

47 start <- P.getPosition

50 start <- P.getPosition

48 comments <- C.readComments

51 comments <- C.readComments

@@ -123,13 +126,17 @@ parseFixityDeclaration :: TokenParser Declaration

123parseFixityDeclaration = do

126parseFixityDeclaration = do

124 fixity <- parseFixity

127 fixity <- parseFixity

125 indented

128 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))

129 where

131 where

130− aliased = (AliasValue . Ident <$> identifier)

132+ typeFixity fixity =

131− <|> (AliasConstructor <$> properName)

133+ TypeFixity fixity

132− <|> reserved "type" *> (AliasType <$> properName)

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)

133

140

134parseImportDeclaration :: TokenParser Declaration

141parseImportDeclaration :: TokenParser Declaration

135parseImportDeclaration = do

142parseImportDeclaration = do

@@ -154,10 +161,11 @@ parseDeclarationRef :: TokenParser DeclarationRef

154parseDeclarationRef =

161parseDeclarationRef =

155 withSourceSpan PositionedDeclarationRef

162 withSourceSpan PositionedDeclarationRef

156 $ (ValueRef <$> parseIdent)

163 $ (ValueRef <$> parseIdent)

164+ <|> (ValueOpRef <$> parens parseOperator)

157 <|> parseTypeRef

165 <|> parseTypeRef

158 <|> (TypeClassRef <$> (reserved "class" *> properName))

166 <|> (TypeClassRef <$> (reserved "class" *> properName))

159 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

167 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

160− <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol)))

168+ <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator))

161 where

169 where

162 parseTypeRef = do

170 parseTypeRef = do

163 name <- properName

171 name <- properName

@@ -323,8 +331,7 @@ parseIdentifierAndValue =

323parseAbs :: TokenParser Expr

331parseAbs :: TokenParser Expr

324parseAbs = do

332parseAbs = do

325 symbol' "\\"

333 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)))

328 C.indented *> rarrow

335 C.indented *> rarrow

329 value <- parseValue

336 value <- parseValue

330 return $ toFunction args value

337 return $ toFunction args value

@@ -343,7 +350,7 @@ parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (

343 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

350 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

344

351

345parseCaseAlternative :: TokenParser CaseAlternative

352parseCaseAlternative :: TokenParser CaseAlternative

346−parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)

353+parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

347 <*> (Left <$> (C.indented *>

354 <*> (Left <$> (C.indented *>

348 P.many1 ((,) <$> parseGuard

355 P.many1 ((,) <$> parseGuard

349 <*> (indented *> rarrow *> parseValue)

356 <*> (indented *> rarrow *> parseValue)

@@ -383,6 +390,7 @@ parseValueAtom = P.choice

383 , parseDo

390 , parseDo

384 , parseLet

391 , parseLet

385 , P.try $ Parens <$> parens parseValue

392 , P.try $ Parens <$> parens parseValue

393+ , Op <$> parseQualified (parens parseOperator)

386 , parseHole

394 , parseHole

387 ]

395 ]

388

396

@@ -390,8 +398,9 @@ parseValueAtom = P.choice

390-- Parse an expression in backticks or an operator

398-- Parse an expression in backticks or an operator

391--

399--

392parseInfixExpr :: TokenParser Expr

400parseInfixExpr :: TokenParser Expr

401+parseInfixExpr

393−parseInfixExpr = P.between tick tick parseValue

402+ = P.between tick tick parseValue

394− <|> Var <$> parseQualified (Op <$> symbol)

403+ <|> Op <$> parseQualified parseOperator

395

404

396parseHole :: TokenParser Expr

405parseHole :: TokenParser Expr

397parseHole = Hole <$> holeLit

406parseHole = Hole <$> holeLit

@@ -481,9 +490,7 @@ parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinde

481

490

482parseVarOrNamedBinder :: TokenParser Binder

491parseVarOrNamedBinder :: TokenParser Binder

483parseVarOrNamedBinder = do

492parseVarOrNamedBinder = 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

487 let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)

494 let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)

488 parseNamedBinder <|> return (VarBinder name)

495 parseNamedBinder <|> return (VarBinder name)

489

496

@@ -522,7 +529,7 @@ parseBinder =

522 ]

529 ]

523

530

524 parseOpBinder :: TokenParser Binder

531 parseOpBinder :: TokenParser Binder

525− parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)

532+ parseOpBinder = OpBinder <$> parseQualified parseOperator

526

533

527parseBinderAtom :: TokenParser Binder

534parseBinderAtom :: TokenParser Binder

528parseBinderAtom = P.choice

535parseBinderAtom = P.choice

src/Language/PureScript/Parser/Types.hs+1−2

@@ -12,7 +12,6 @@ import Control.Monad (when, unless)

12

13import Language.PureScript.AST.SourcePos

14import Language.PureScript.Environment

15−import Language.PureScript.Names

16import Language.PureScript.Parser.Common

15import Language.PureScript.Parser.Common

17import Language.PureScript.Parser.Kinds

16import Language.PureScript.Parser.Kinds

18import Language.PureScript.Parser.Lexer

17import Language.PureScript.Parser.Lexer

@@ -83,7 +82,7 @@ parseAnyType :: TokenParser Type

83parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

82parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

84 where

83 where

85 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

84 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

86− , [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident ->

85+ , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->

87 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

86 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

88 ]

87 ]

89 , [ P.Infix (rarrow >> return function) P.AssocRight ]

88 , [ P.Infix (rarrow >> return function) P.AssocRight ]

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -40,7 +40,7 @@ typeLiterals = mkPattern match

40 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

41 match (BinaryNoParensType op l r) =

42 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

44 match _ = Nothing

45

46constraintsAsBox :: [Constraint] -> Box -> Box

src/Language/PureScript/Pretty/Values.hs+3−2

@@ -71,6 +71,7 @@ prettyPrintValue _ (Hole name) = text "?" <> text name

71prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

72prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

73prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

74+prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr

74prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr

75prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr

75prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr

76prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr

76prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

77prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

@@ -85,7 +86,7 @@ prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

85prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

86prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

86 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

87 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

87 where

88 where

88− printOp (Var (Qualified _ (Op opName))) = text opName

89+ printOp (Op (Qualified _ name)) = text (runOpName name)

89 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

90 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

90prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

91prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

91prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

92prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

@@ -154,7 +155,7 @@ prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

154prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

155prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

155prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

156prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

156prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

157prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

157−prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)

158+prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op)

158prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

159prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

159 prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

160 prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

160prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

161prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

src/Language/PureScript/Sugar.hs+13−7

@@ -3,14 +3,15 @@

3--

4module Language.PureScript.Sugar (desugar, module S) where

5

6−import Prelude.Compat

7−

8import Control.Category ((>>>))

6import Control.Category ((>>>))

9import Control.Monad

7import Control.Monad

10import Control.Monad.Error.Class (MonadError())

8import Control.Monad.Error.Class (MonadError())

11import Control.Monad.Supply.Class

9import Control.Monad.Supply.Class

12import Control.Monad.Writer.Class (MonadWriter())

10import Control.Monad.Writer.Class (MonadWriter())

13

11

12+import Data.List (map)

13+import Data.Traversable (traverse)

14+

14import Language.PureScript.AST

15import Language.PureScript.AST

15import Language.PureScript.Errors

16import Language.PureScript.Errors

16import Language.PureScript.Externs

17import Language.PureScript.Externs

@@ -47,15 +48,20 @@ import Language.PureScript.Sugar.TypeDeclarations as S

47--

48--

48-- * Group mutually recursive value and data declarations into binding groups.

49-- * Group mutually recursive value and data declarations into binding groups.

49--

50--

51+desugar

50−desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

52+ :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

53+ => [ExternsFile]

54+ -> [Module]

55+ -> m [Module]

51desugar externs =

56desugar externs =

52− map removeSignedLiterals

57+ map desugarSignedLiterals

53 >>> traverse desugarObjectConstructors

58 >>> traverse desugarObjectConstructors

54 >=> traverse desugarDoModule

59 >=> traverse desugarDoModule

55− >=> desugarCasesModule

60+ >=> traverse desugarCasesModule

56− >=> desugarTypeDeclarationsModule

61+ >=> traverse desugarTypeDeclarationsModule

57 >=> desugarImports externs

62 >=> desugarImports externs

58 >=> rebracket externs

63 >=> rebracket externs

64+ >=> traverse checkFixityExports

59 >=> traverse deriveInstances

65 >=> traverse deriveInstances

60 >=> desugarTypeClasses externs

66 >=> desugarTypeClasses externs

61− >=> createBindingGroupsModule

67+ >=> traverse createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+18−19

@@ -31,11 +31,10 @@ import Language.PureScript.Types

31--

32createBindingGroupsModule

33 :: (MonadError MultipleErrors m)

34− => [Module]

34+ => Module

35− -> m [Module]

35+ -> m Module

36−createBindingGroupsModule =

36+createBindingGroupsModule (Module ss coms name ds exps) =

37− mapM $ \(Module ss coms name ds exps) ->

38− Module ss coms name <$> createBindingGroups name ds <*> pure exps

37+ Module ss coms name <$> createBindingGroups name ds <*> pure exps

39

38

40-- |

39-- |

41-- Collapse all binding groups in a module to individual declarations

40-- Collapse all binding groups in a module to individual declarations

@@ -67,11 +66,11 @@ createBindingGroups moduleName = mapM f <=< handleDecls

67 handleDecls ds = do

66 handleDecls ds = do

68 let values = filter isValueDecl ds

67 let values = filter isValueDecl ds

69 dataDecls = filter isDataDecl ds

68 dataDecls = filter isDataDecl ds

70− allProperNames = map getTypeName dataDecls

69+ allProperNames = map declTypeName dataDecls

71− dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls

70+ dataVerts = map (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls

72 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

71 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

73− let allIdents = map getIdent values

72+ let allIdents = map declIdent values

74− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

73+ valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values

75 bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

74 bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

76 return $ filter isImportDecl ds ++

75 return $ filter isImportDecl ds ++

77 filter isExternDataDecl ds ++

76 filter isExternDataDecl ds ++

@@ -149,16 +148,16 @@ usedTypeNames moduleName =

149 | moduleName == moduleName' = [name]

148 | moduleName == moduleName' = [name]

150 usedNames _ = []

149 usedNames _ = []

151

150

152−getIdent :: Declaration -> Ident

151+declIdent :: Declaration -> Ident

153−getIdent (ValueDeclaration ident _ _ _) = ident

152+declIdent (ValueDeclaration ident _ _ _) = ident

154−getIdent (PositionedDeclaration _ _ d) = getIdent d

153+declIdent (PositionedDeclaration _ _ d) = declIdent d

155−getIdent _ = internalError "Expected ValueDeclaration"

154+declIdent _ = internalError "Expected ValueDeclaration"

156

155

157−getTypeName :: Declaration -> ProperName 'TypeName

156+declTypeName :: Declaration -> ProperName 'TypeName

158−getTypeName (DataDeclaration _ pn _ _) = pn

157+declTypeName (DataDeclaration _ pn _ _) = pn

159−getTypeName (TypeSynonymDeclaration pn _ _) = pn

158+declTypeName (TypeSynonymDeclaration pn _ _) = pn

160−getTypeName (PositionedDeclaration _ _ d) = getTypeName d

159+declTypeName (PositionedDeclaration _ _ d) = declTypeName d

161−getTypeName _ = internalError "Expected DataDeclaration"

160+declTypeName _ = internalError "Expected DataDeclaration"

162

161

163-- |

162-- |

164-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

163-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

@@ -187,7 +186,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

187 idents = map (\(_, i, _) -> i) valueVerts

186 idents = map (\(_, i, _) -> i) valueVerts

188

187

189 valueVerts :: [(Declaration, Ident, [Ident])]

188 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'

191

190

192 toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)

191 toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)

193 toBinding (AcyclicSCC d) = return $ fromValueDecl d

192 toBinding (AcyclicSCC d) = return $ fromValueDecl d

src/Language/PureScript/Sugar/CaseDeclarations.hs+9−4

@@ -12,7 +12,7 @@ import Prelude.Compat

12import Data.List (nub, groupBy, foldl1')

13import Data.Maybe (catMaybes, mapMaybe)

14

15−import Control.Monad ((<=<), forM, replicateM, join, unless)

15+import Control.Monad ((<=<), replicateM, join, unless)

16import Control.Monad.Error.Class (MonadError(..))

17import Control.Monad.Supply.Class

18

@@ -32,10 +32,15 @@ isLeft (Right _) = False

32-- |

33-- Replace all top-level binders in a module with case expressions.

34--

35+desugarCasesModule

35−desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

36+ :: (MonadSupply m, MonadError MultipleErrors m)

37+ => Module

38+ -> m Module

36−desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

39+desugarCasesModule (Module ss coms name ds exps) =

37 rethrow (addHint (ErrorInModule name)) $

40 rethrow (addHint (ErrorInModule name)) $

41+ Module ss coms name

38− Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps

42+ <$> (desugarCases <=< desugarAbs <=< validateCases $ ds)

43+ <*> pure exps

39

44

40-- |

45-- |

41-- Validates that case head and binder lengths match.

46-- Validates that case head and binder lengths match.

src/Language/PureScript/Sugar/Names.hs+60−69

@@ -37,7 +37,12 @@ import Language.PureScript.Types

37-- Replaces all local names with qualified names within a list of modules. The

38-- modules should be topologically sorted beforehand.

39--

40+desugarImports

41+ :: forall m

40−desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

42+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

43+ => [ExternsFile]

44+ -> [Module]

45+ -> m [Module]

41desugarImports externs modules =

46desugarImports externs modules =

42 fmap snd (desugarImportsWithEnv externs modules)

47 fmap snd (desugarImportsWithEnv externs modules)

43

48

@@ -63,7 +68,7 @@ desugarImportsWithEnv externs modules = do

63 env' = M.insert efModuleName (ss, nullImports, members) env

68 env' = M.insert efModuleName (ss, nullImports, members) env

64 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])

69 fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])

65 imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

70 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

67 return $ M.insert efModuleName (ss, imps, exps) env

72 return $ M.insert efModuleName (ss, imps, exps) env

68 where

73 where

69

74

@@ -77,24 +82,18 @@ desugarImportsWithEnv externs modules = do

77 forTyCon _ = Nothing

82 forTyCon _ = Nothing

78 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

83 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

79 toExportedType _ = Nothing

84 toExportedType _ = Nothing

85+

80− exportedTypeOps :: [(Ident, ModuleName)]

86+ exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

81− exportedTypeOps = mapMaybe toExportedTypeOp efExports

87+ exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports

82− where

88+

83− toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName)

84− toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r

85− toExportedTypeOp _ = Nothing

86 exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

89 exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

87− exportedTypeClasses = mapMaybe toExportedTypeClass efExports

90+ exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports

88− where

91+

89− toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

90− toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r

91− toExportedTypeClass _ = Nothing

92 exportedValues :: [(Ident, ModuleName)]

93− exportedValues = mapMaybe toExportedValue efExports

93+ exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports

94− where

94+

95− toExportedValue (ValueRef ident) = Just (ident, efModuleName)

95+ exportedValueOps :: [(OpName 'ValueOpName, ModuleName)]

96− toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

96+ exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports

97− toExportedValue _ = Nothing

98

97

99 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

98 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

100 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

99 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

@@ -104,7 +103,7 @@ desugarImportsWithEnv externs modules = do

104 members <- findExportable m

103 members <- findExportable m

105 let env' = M.insert mn (ss, nullImports, members) env

104 let env' = M.insert mn (ss, nullImports, members) env

106 (m', imps) <- resolveImports env' m

105 (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

108 return (m' : ms, M.insert mn (ss, imps, exps) env)

107 return (m' : ms, M.insert mn (ss, imps, exps) env)

109

108

110 renameInModule' :: Env -> Module -> m Module

109 renameInModule' :: Env -> Module -> m Module

@@ -127,6 +126,7 @@ elaborateExports exps (Module ss coms mn decls refs) =

127 map TypeOpRef (my exportedTypeOps) ++

126 map TypeOpRef (my exportedTypeOps) ++

128 map TypeClassRef (my exportedTypeClasses) ++

127 map TypeClassRef (my exportedTypeClasses) ++

129 map ValueRef (my exportedValues) ++

128 map ValueRef (my exportedValues) ++

129+ map ValueOpRef (my exportedValueOps) ++

130 maybe [] (filter isModuleRef) refs

131 where

132 -- 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) =

169 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

170 updateDecl (pos, bound) (ExternDeclaration name ty) =

171 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

172− updateDecl (pos, bound) (FixityDeclaration fx name alias) =

172+ updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) =

173− (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias)

173+ (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op)

174− where

174+ updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) =

175− updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias)

176− updateAlias (Qualified mn' (AliasValue ident)) =

177− fmap AliasValue <$> updateValueName (Qualified mn' ident) pos

175+ (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op)

178− updateAlias (Qualified mn' (AliasConstructor ctor)) =

176+ updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) =

179− fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos

177+ (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op)

180− updateAlias (Qualified mn' (AliasType ty)) =

181− fmap AliasType <$> updateTypeName (Qualified mn' ty) pos

182 updateDecl s d = return (s, d)

178 updateDecl s d = return (s, d)

183

179

184 updateValue

180 updateValue

@@ -199,6 +195,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

199 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

195 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

200 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

196 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

201 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

197 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

198+ updateValue (pos, bound) (Op op) =

199+ (,) (pos, bound) <$> (Op <$> updateValueOpName op pos)

202 updateValue s@(pos, _) (Constructor name) =

200 updateValue s@(pos, _) (Constructor name) =

203 (,) s <$> (Constructor <$> updateDataConstructorName name pos)

201 (,) s <$> (Constructor <$> updateDataConstructorName name pos)

204 updateValue s@(pos, _) (TypedValue check val ty) =

202 updateValue s@(pos, _) (TypedValue check val ty) =

@@ -213,8 +211,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

213 return ((Just pos, bound), v)

211 return ((Just pos, bound), v)

214 updateBinder s@(pos, _) (ConstructorBinder name b) =

212 updateBinder s@(pos, _) (ConstructorBinder name b) =

215 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

213 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

216− updateBinder s@(pos, _) (OpBinder name) =

214+ updateBinder s@(pos, _) (OpBinder op) =

217− (,) s <$> (OpBinder <$> updateValueName name pos)

215+ (,) s <$> (OpBinder <$> updateValueOpName op pos)

218 updateBinder s (TypedBinder t b) = do

216 updateBinder s (TypedBinder t b) = do

219 (s'@ (span', _), b') <- updateBinder s b

217 (s'@ (span', _), b') <- updateBinder s b

220 t' <- updateTypesEverywhere span' t

218 t' <- updateTypesEverywhere span' t

@@ -254,23 +252,14 @@ renameInModule env imports (Module ss coms mn decls exps) =

254 -> Maybe SourceSpan

252 -> Maybe SourceSpan

255 -> m (Qualified (ProperName 'TypeName))

253 -> m (Qualified (ProperName 'TypeName))

256 updateTypeName =

254 updateTypeName =

257− update UnknownType

258− (importedTypes imports)

259− (resolveType . exportedTypes)

255+ update (importedTypes imports) (resolveType . exportedTypes) TyName

260− TyName

261− (("type " ++) . runProperName)

262

256

263 updateTypeOpName

257 updateTypeOpName

264− :: Qualified Ident

258+ :: Qualified (OpName 'TypeOpName)

265 -> Maybe SourceSpan

259 -> Maybe SourceSpan

266− -> m (Qualified Ident)

260+ -> m (Qualified (OpName 'TypeOpName))

267 updateTypeOpName =

261 updateTypeOpName =

268− update

269− UnknownTypeOp

270− (importedTypeOps imports)

262+ update (importedTypeOps imports) (resolve . exportedTypeOps) TyOpName

271− (resolve . exportedTypeOps)

272− TyOpName

273− (("type operator" ++) . runIdent)

274

263

275 updateDataConstructorName

264 updateDataConstructorName

276 :: Qualified (ProperName 'ConstructorName)

265 :: Qualified (ProperName 'ConstructorName)

@@ -278,11 +267,9 @@ renameInModule env imports (Module ss coms mn decls exps) =

278 -> m (Qualified (ProperName 'ConstructorName))

267 -> m (Qualified (ProperName 'ConstructorName))

279 updateDataConstructorName =

268 updateDataConstructorName =

280 update

269 update

281− (flip UnknownDataConstructor Nothing)

282 (importedDataConstructors imports)

270 (importedDataConstructors imports)

283 (resolveDctor . exportedTypes)

271 (resolveDctor . exportedTypes)

284 DctorName

272 DctorName

285− (("data constructor " ++) . runProperName)

286

273

287 updateClassName

274 updateClassName

288 :: Qualified (ProperName 'ClassName)

275 :: Qualified (ProperName 'ClassName)

@@ -290,20 +277,20 @@ renameInModule env imports (Module ss coms mn decls exps) =

290 -> m (Qualified (ProperName 'ClassName))

277 -> m (Qualified (ProperName 'ClassName))

291 updateClassName =

278 updateClassName =

292 update

279 update

293− UnknownTypeClass

294 (importedTypeClasses imports)

280 (importedTypeClasses imports)

295 (resolve . exportedTypeClasses)

281 (resolve . exportedTypeClasses)

296 TyClassName

282 TyClassName

297− (("class " ++) . runProperName)

298

283

299 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

284 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

300 updateValueName =

285 updateValueName =

301− update

302− UnknownValue

303− (importedValues imports)

286+ update (importedValues imports) (resolve . exportedValues) IdentName

304− (resolve . exportedValues)

287+

305− IdentName

288+ updateValueOpName

306− (("value " ++) . runIdent)

289+ :: Qualified (OpName 'ValueOpName)

290+ -> Maybe SourceSpan

291+ -> m (Qualified (OpName 'ValueOpName))

292+ updateValueOpName =

293+ update (importedValueOps imports) (resolve . exportedValueOps) ValOpName

307

294

308 -- Used when performing an update to qualify values and classes with their

295 -- Used when performing an update to qualify values and classes with their

309 -- module of original definition.

296 -- module of original definition.

@@ -316,7 +303,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

316 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

303 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

317 -> ProperName 'TypeName

304 -> ProperName 'TypeName

318 -> Maybe (Qualified (ProperName 'TypeName))

305 -> Maybe (Qualified (ProperName 'TypeName))

306+ resolveType tys name =

319− resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

307+ mkQualified name . snd <$> find ((== name) . fst . fst) tys

320

308

321 -- Used when performing an update to qualify data constructors with their

309 -- Used when performing an update to qualify data constructors with their

322 -- module of original definition.

310 -- module of original definition.

@@ -324,22 +312,21 @@ renameInModule env imports (Module ss coms mn decls exps) =

324 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

312 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

325 -> ProperName 'ConstructorName

313 -> ProperName 'ConstructorName

326 -> Maybe (Qualified (ProperName 'ConstructorName))

314 -> Maybe (Qualified (ProperName 'ConstructorName))

315+ resolveDctor tys name =

327− resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

316+ mkQualified name . snd <$> find (elem name . snd . fst) tys

328

317

329 -- Update names so unqualified references become qualified, and locally

318 -- Update names so unqualified references become qualified, and locally

330 -- qualified references are replaced with their canoncial qualified names

319 -- qualified references are replaced with their canoncial qualified names

331 -- (e.g. M.Map -> Data.Map.Map).

320 -- (e.g. M.Map -> Data.Map.Map).

332 update

321 update

333 :: (Ord a, Show a)

322 :: (Ord a, Show a)

334− => (Qualified a -> SimpleErrorMessage)

335− -> M.Map (Qualified a) [ImportRecord a]

323+ => M.Map (Qualified a) [ImportRecord a]

336 -> (Exports -> a -> Maybe (Qualified a))

324 -> (Exports -> a -> Maybe (Qualified a))

337− -> (Qualified a -> Name)

325+ -> (a -> Name)

338− -> (a -> String)

339 -> Qualified a

326 -> Qualified a

340 -> Maybe SourceSpan

327 -> Maybe SourceSpan

341 -> m (Qualified a)

328 -> 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 $

343 case (M.lookup qname imps, mn') of

330 case (M.lookup qname imps, mn') of

344

331

345 -- We found the name in our imports, so we return the name for it,

332 -- 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) =

348 -- re-exports. If there are multiple options for the name to resolve to

335 -- re-exports. If there are multiple options for the name to resolve to

349 -- in scope, we throw an error.

336 -- in scope, we throw an error.

350 (Just options, _) -> do

337 (Just options, _) -> do

351− (mnNew, mnOrig) <- checkImportConflicts mn render options

338+ (mnNew, mnOrig) <- checkImportConflicts mn toName options

339+ modify $ \result ->

340+ M.insert

341+ mnNew

352− modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

342+ (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result))

343+ result

353 return $ Qualified (Just mnOrig) name

344 return $ Qualified (Just mnOrig) name

354

345

355 -- If the name wasn't found in our imports but was qualified then we need

346 -- If the name wasn't found in our imports but was qualified then we need

356 -- to check whether it's a failed import from a "pseudo" module (created

347 -- to check whether it's a failed import from a "pseudo" module (created

357 -- by qualified importing). If that's not the case, then we just need to

348 -- by qualified importing). If that's not the case, then we just need to

358 -- check it refers to a symbol in another module.

349 -- check it refers to a symbol in another module.

359− (Nothing, Just mn'') -> do

350+ (Nothing, Just mn'') ->

360 case M.lookup mn'' env of

351 case M.lookup mn'' env of

361 Nothing

352 Nothing

362 | mn'' `S.member` importedVirtualModules imports -> throwUnknown

353 | mn'' `S.member` importedVirtualModules imports -> throwUnknown

354+ | otherwise ->

363− | otherwise -> throwError . errorMessage $ UnknownModule mn''

355+ throwError . errorMessage .

356+ UnknownName . Qualified Nothing $ ModName mn''

364 Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

357 Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

365

358

366 -- If neither of the above cases are true then it's an undefined or

359 -- 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) =

368 _ -> throwUnknown

361 _ -> throwUnknown

369

362

370 where

363 where

371− positioned err = case pos of

372− Nothing -> err

373− Just pos' -> rethrowWithPosition pos' err

364+ positioned err = maybe err (`rethrowWithPosition` err) pos

374− throwUnknown = throwError . errorMessage $ unknown qname

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

2+

3+import Prelude.Compat

4+

5+import Control.Monad.Writer (MonadWriter(..))

6+

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

14 , exportTypeOp

15 , exportTypeClass

16 , exportValue

17+ , exportValueOp

17 , getExports

18 , getExports

18 , checkImportConflicts

19 , checkImportConflicts

19 ) where

20 ) where

@@ -26,12 +27,11 @@ import Control.Monad.Writer.Class (MonadWriter(..))

26

27

27import Data.Function (on)

28import Data.Function (on)

28import Data.List (groupBy, sortBy, nub, delete)

29import Data.List (groupBy, sortBy, nub, delete)

29−import Data.Maybe (fromJust)

30+import Data.Maybe (fromJust, mapMaybe)

30import qualified Data.Map as M

31import qualified Data.Map as M

31import qualified Data.Set as S

32import qualified Data.Set as S

32

33

33import Language.PureScript.AST

34import Language.PureScript.AST

34−import Language.PureScript.Crash

35import Language.PureScript.Environment

36import Language.PureScript.Errors

37import Language.PureScript.Names

@@ -60,6 +60,8 @@ data ImportProvenance

60 | Local

61 deriving (Eq, Ord, Show, Read)

62

63+type ImportMap a = M.Map (Qualified a) [ImportRecord a]

64+

63-- |

65-- |

64-- The imported declarations for a module, including the module's own members.

66-- The imported declarations for a module, including the module's own members.

65--

67--

@@ -68,23 +70,27 @@ data Imports = Imports

68 -- |

70 -- |

69 -- Local names for types within a module mapped to to their qualified names

71 -- Local names for types within a module mapped to to their qualified names

70 --

72 --

71− importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]

73+ importedTypes :: ImportMap (ProperName 'TypeName)

72 -- |

74 -- |

73 -- Local names for type operators within a module mapped to to their qualified names

75 -- Local names for type operators within a module mapped to to their qualified names

74 --

76 --

75− , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident]

77+ , importedTypeOps :: ImportMap (OpName 'TypeOpName)

76 -- |

78 -- |

77 -- Local names for data constructors within a module mapped to to their qualified names

79 -- Local names for data constructors within a module mapped to to their qualified names

78 --

80 --

79− , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]

81+ , importedDataConstructors :: ImportMap (ProperName 'ConstructorName)

80 -- |

82 -- |

81 -- Local names for classes within a module mapped to to their qualified names

83 -- Local names for classes within a module mapped to to their qualified names

82 --

84 --

83− , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]

85+ , importedTypeClasses :: ImportMap (ProperName 'ClassName)

84 -- |

86 -- |

85 -- Local names for values within a module mapped to to their qualified names

87 -- Local names for values within a module mapped to to their qualified names

86 --

88 --

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)

88 -- |

94 -- |

89 -- The modules that have been imported into the current scope.

95 -- The modules that have been imported into the current scope.

90 --

96 --

@@ -100,7 +106,7 @@ data Imports = Imports

100-- An empty 'Imports' value.

106-- An empty 'Imports' value.

101--

107--

102nullImports :: Imports

108nullImports :: 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

104

110

105-- |

111-- |

106-- The exported declarations from a module.

112-- The exported declarations from a module.

@@ -116,7 +122,7 @@ data Exports = Exports

116 -- The type operators exported from each module along with the module they

122 -- The type operators exported from each module along with the module they

117 -- originally came from.

123 -- originally came from.

118 --

124 --

119− , exportedTypeOps :: [(Ident, ModuleName)]

125+ , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)]

120 -- |

126 -- |

121 -- The classes exported from each module along with the module they originally

127 -- The classes exported from each module along with the module they originally

122 -- came from.

128 -- came from.

@@ -127,13 +133,18 @@ data Exports = Exports

127 -- came from.

133 -- came from.

128 --

134 --

129 , exportedValues :: [(Ident, ModuleName)]

135 , 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)]

130 } deriving (Show, Read)

141 } deriving (Show, Read)

131

142

132-- |

143-- |

133-- An empty 'Exports' value.

144-- An empty 'Exports' value.

134--

145--

135nullExports :: Exports

146nullExports :: Exports

136−nullExports = Exports [] [] [] []

147+nullExports = Exports [] [] [] [] []

137

148

138-- |

149-- |

139-- The imports and exports for a collection of modules. The 'SourceSpan' is used

150-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -164,7 +175,11 @@ envModuleExports (_, _, exps) = exps

164-- The exported types from the @Prim@ module

175-- The exported types from the @Prim@ module

165--

176--

166primExports :: Exports

177primExports :: Exports

178+primExports =

179+ nullExports

180+ { exportedTypes = mkTypeEntry `map` M.keys primTypes

167−primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) []

181+ , exportedTypeClasses = mkClassEntry `map` M.keys primClasses

182+ }

168 where

183 where

169 mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

184 mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

170 mkClassEntry (Qualified mn name) = (name, fromJust mn)

185 mkClassEntry (Qualified mn name) = (name, fromJust mn)

@@ -179,53 +194,100 @@ primEnv = M.singleton

179-- Safely adds a type and its data constructors to some exports, returning an

194-- Safely adds a type and its data constructors to some exports, returning an

180-- error if a conflict occurs.

195-- error if a conflict occurs.

181--

196--

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

183exportType exps name dctors mn = do

204exportType exps name dctors mn = do

184 let exTypes' = exportedTypes exps

205 let exTypes' = exportedTypes exps

185 let exTypes = filter ((/= mn) . snd) exTypes'

206 let exTypes = filter ((/= mn) . snd) exTypes'

186 let exDctors = (snd . fst) `concatMap` exTypes

207 let exDctors = (snd . fst) `concatMap` exTypes

187 let exClasses = exportedTypeClasses exps

208 let exClasses = exportedTypeClasses exps

209+ when (any ((== name) . fst . fst) exTypes) $

188− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

210+ throwConflictError ConflictingTypeDecls name

211+ when (any ((== coerceProperName name) . fst) exClasses) $

189− when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

212+ throwConflictError TypeConflictsWithClass name

190 forM_ dctors $ \dctor -> do

213 forM_ dctors $ \dctor -> do

214+ when (dctor `elem` exDctors) $

191− when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

215+ throwConflictError ConflictingCtorDecls dctor

216+ when (any ((== coerceProperName dctor) . fst) exClasses) $

192− when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

217+ throwConflictError CtorConflictsWithClass dctor

193 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

218 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

194

219

195-- |

220-- |

196-- Safely adds a type operator to some exports, returning an error if a

221-- Safely adds a type operator to some exports, returning an error if a

197-- conflict occurs.

222-- conflict occurs.

198--

223--

224+exportTypeOp

199−exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

225+ :: MonadError MultipleErrors m

226+ => Exports

227+ -> OpName 'TypeOpName

228+ -> ModuleName

229+ -> m Exports

200−exportTypeOp exps name mn = do

230+exportTypeOp exps op mn = do

201− typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps)

231+ typeOps <- addExport DuplicateTypeOpExport op mn (exportedTypeOps exps)

202 return $ exps { exportedTypeOps = typeOps }

232 return $ exps { exportedTypeOps = typeOps }

203

233

204-- |

234-- |

205-- Safely adds a class to some exports, returning an error if a conflict occurs.

235-- Safely adds a class to some exports, returning an error if a conflict occurs.

206--

236--

237+exportTypeClass

207−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

238+ :: MonadError MultipleErrors m

239+ => Exports

240+ -> ProperName 'ClassName

241+ -> ModuleName

242+ -> m Exports

208exportTypeClass exps name mn = do

243exportTypeClass exps name mn = do

209 let exTypes = exportedTypes exps

244 let exTypes = exportedTypes exps

210 let exDctors = (snd . fst) `concatMap` exTypes

245 let exDctors = (snd . fst) `concatMap` exTypes

246+ when (any ((== coerceProperName name) . fst . fst) exTypes) $

211− when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

247+ throwConflictError ClassConflictsWithType name

248+ when (coerceProperName name `elem` exDctors) $

212− when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

249+ throwConflictError ClassConflictsWithCtor name

213 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

250 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

214 return $ exps { exportedTypeClasses = classes }

251 return $ exps { exportedTypeClasses = classes }

215

252

216-- |

253-- |

217-- Safely adds a value to some exports, returning an error if a conflict occurs.

254-- Safely adds a value to some exports, returning an error if a conflict occurs.

218--

255--

256+exportValue

219−exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

257+ :: MonadError MultipleErrors m

258+ => Exports

259+ -> Ident

260+ -> ModuleName

261+ -> m Exports

220exportValue exps name mn = do

262exportValue exps name mn = do

221 values <- addExport DuplicateValueExport name mn (exportedValues exps)

263 values <- addExport DuplicateValueExport name mn (exportedValues exps)

222 return $ exps { exportedValues = values }

264 return $ exps { exportedValues = values }

223

265

224-- |

266-- |

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+-- |

225−-- Adds an entry to a list of exports unless it is already present, in which case an error is

281+-- Adds an entry to a list of exports unless it is already present, in which

226−-- returned.

282+-- case an error is returned.

227--

283--

284+addExport

228−addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

285+ :: (MonadError MultipleErrors m, Eq a)

286+ => (a -> SimpleErrorMessage)

287+ -> a

288+ -> ModuleName

289+ -> [(a, ModuleName)]

290+ -> m [(a, ModuleName)]

229addExport what name mn exports =

291addExport what name mn exports =

230 if any (\(name', mn') -> name == name' && mn /= mn') exports

292 if any (\(name', mn') -> name == name' && mn /= mn') exports

231 then throwConflictError what name

293 then throwConflictError what name

@@ -234,12 +296,22 @@ addExport what name mn exports =

234-- |

296-- |

235-- Raises an error for when there is more than one definition for something.

297-- Raises an error for when there is more than one definition for something.

236--

298--

299+throwConflictError

237−throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b

300+ :: MonadError MultipleErrors m

301+ => (a -> SimpleErrorMessage)

302+ -> a

303+ -> m b

238throwConflictError conflict = throwError . errorMessage . conflict

304throwConflictError conflict = throwError . errorMessage . conflict

239

305

306+-- |

240−-- Gets the exports for a module, or an error message if the module doesn't exist

307+-- Gets the exports for a module, or raise an error if the module doesn't exist.

308+--

241−getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

309+getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports

242−getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

310+getExports env mn =

311+ maybe

312+ (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn)

313+ (return . envModuleExports)

314+ $ M.lookup mn env

243

315

244-- |

316-- |

245-- When reading a value from the imports, check that there are no conflicts in

317-- When reading a value from the imports, check that there are no conflicts in

@@ -249,16 +321,16 @@ checkImportConflicts

249 :: forall m a

321 :: forall m a

250 . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)

322 . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)

251 => ModuleName

323 => ModuleName

252− -> (a -> String)

324+ -> (a -> Name)

253 -> [ImportRecord a]

325 -> [ImportRecord a]

254 -> m (ModuleName, ModuleName)

326 -> m (ModuleName, ModuleName)

255−checkImportConflicts currentModule render xs =

327+checkImportConflicts currentModule toName xs =

256 let

328 let

257 byOrig = sortBy (compare `on` importSourceModule) xs

329 byOrig = sortBy (compare `on` importSourceModule) xs

258 groups = groupBy ((==) `on` importSourceModule) byOrig

330 groups = groupBy ((==) `on` importSourceModule) byOrig

259 nonImplicit = filter ((/= FromImplicit) . importProvenance) xs

331 nonImplicit = filter ((/= FromImplicit) . importProvenance) xs

260− name = render' (importName . head $ xs)

332+ name = toName . disqualify . importName $ head xs

261− conflictModules = map (getQual . importName . head) groups

333+ conflictModules = mapMaybe (getQual . importName . head) groups

262 in

334 in

263 if length groups > 1

335 if length groups > 1

264 then case nonImplicit of

336 then case nonImplicit of

@@ -270,9 +342,3 @@ checkImportConflicts currentModule render xs =

270 else

342 else

271 let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig

343 let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig

272 in return (mnNew, mnOrig)

344 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

18import Language.PureScript.Crash

19import Language.PureScript.Errors

20import 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)

22

23

23-- |

24-- |

24-- Finds all exportable members of a module, disregarding any explicit exports.

25-- Finds all exportable members of a module, disregarding any explicit exports.

@@ -39,8 +40,8 @@ findExportable (Module _ _ mn ds _) =

39 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

40 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

40 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

41 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

41 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

42 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

42− updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn

43+ updateExports exps (ValueFixityDeclaration _ _ op) = exportValueOp exps op mn

43− updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

44+ updateExports exps (TypeFixityDeclaration _ _ op) = exportTypeOp exps op mn

44 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

45 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

45 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

46 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

46 updateExports exps _ = return exps

47 updateExports exps _ = return exps

@@ -49,62 +50,59 @@ findExportable (Module _ _ mn ds _) =

49-- Resolves the exports for a module, filtering out members that have not been

50-- Resolves the exports for a module, filtering out members that have not been

50-- exported and elaborating re-exports of other modules.

51-- exported and elaborating re-exports of other modules.

51--

52--

53+resolveExports

54+ :: forall m

52−resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

55+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

56+ => Env

57+ -> SourceSpan

58+ -> ModuleName

59+ -> Imports

60+ -> Exports

61+ -> [DeclarationRef]

62+ -> m Exports

53−resolveExports env mn imps exps refs =

63+resolveExports env ss mn imps exps refs =

54− rethrow (addHint (ErrorInModule mn)) $ do

64+ warnAndRethrow (addHint (ErrorInModule mn)) $ do

55 filtered <- filterModule mn exps refs

65 filtered <- filterModule mn exps refs

56− let (dupeRefs, dupeDctors) = findDuplicateRefs refs

57− warnDupeRefs dupeRefs

58− warnDupeDctors dupeDctors

59− foldM elaborateModuleExports filtered refs

66+ exps' <- foldM elaborateModuleExports filtered refs

60−

67+ warnDuplicateRefs ss DuplicateExportRef refs

68+ return exps'

69+

61 where

70 where

62

71

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−

78 -- Takes the current module's imports, the accumulated list of exports, and a

72 -- Takes the current module's imports, the accumulated list of exports, and a

79 -- `DeclarationRef` for an explicit export. When the ref refers to another

73 -- `DeclarationRef` for an explicit export. When the ref refers to another

80 -- module, export anything from the imports that matches for that module.

74 -- module, export anything from the imports that matches for that module.

81 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

75 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

82 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

76 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

83− rethrowWithPosition pos $ elaborateModuleExports result r

77+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r

84 elaborateModuleExports result (ModuleRef name) | name == mn = do

78 elaborateModuleExports result (ModuleRef name) | name == mn = do

85 let types' = exportedTypes result ++ exportedTypes exps

79 let types' = exportedTypes result ++ exportedTypes exps

86 let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

80 let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

87 let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

81 let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

88 let values' = exportedValues result ++ exportedValues exps

82 let values' = exportedValues result ++ exportedValues exps

83+ let valueOps' = exportedValueOps result ++ exportedValueOps exps

89 return result

84 return result

90 { exportedTypes = types'

85 { exportedTypes = types'

91 , exportedTypeOps = typeOps'

86 , exportedTypeOps = typeOps'

92 , exportedTypeClasses = classes'

87 , exportedTypeClasses = classes'

93 , exportedValues = values'

88 , exportedValues = values'

89+ , exportedValueOps = valueOps'

94 }

90 }

95 elaborateModuleExports result (ModuleRef name) = do

91 elaborateModuleExports result (ModuleRef name) = do

96 let isPseudo = isPseudoModule name

92 let isPseudo = isPseudoModule name

97− when (not isPseudo && not (isImportedModule name)) $

93+ when (not isPseudo && not (isImportedModule name))

98− throwError . errorMessage . UnknownExportModule $ name

94+ . throwError . errorMessage . UnknownExport $ ModName name

99− reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

95+ reTypes <- extract isPseudo name TyName (importedTypes imps)

100− reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps)

96+ reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps)

101− reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

97+ reDctors <- extract isPseudo name DctorName (importedDataConstructors imps)

102− reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

98+ reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)

103− reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

99+ reValues <- extract isPseudo name IdentName (importedValues imps)

100+ reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)

104− result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

101+ foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

105− result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps)

102+ >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)

106− result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses)

103+ >>= flip (foldM (uncurry . exportTypeClass)) (map resolveClass reClasses)

107− foldM (uncurry . exportValue) result''' (map resolveValue reValues)

104+ >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)

105+ >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)

108 elaborateModuleExports result _ = return result

106 elaborateModuleExports result _ = return result

109

107

110 -- Extracts a list of values for a module based on a lookup table. If the

108 -- 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 =

113 :: (Show a, Ord a)

111 :: (Show a, Ord a)

114 => Bool

112 => Bool

115 -> ModuleName

113 -> ModuleName

116− -> (a -> String)

114+ -> (a -> Name)

117 -> M.Map (Qualified a) [ImportRecord a]

115 -> M.Map (Qualified a) [ImportRecord a]

118 -> m [Qualified a]

116 -> 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

120 where

118 where

121 go = filterM $ \(name', options) -> do

119 go = filterM $ \(name', options) -> do

122 let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options

120 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

124 return isMatch

122 return isMatch

125 checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir)

123 checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir)

126

124

@@ -139,6 +137,7 @@ resolveExports env mn imps exps refs =

139 || any (isQualifiedWith mn') (f (importedDataConstructors imps))

137 || any (isQualifiedWith mn') (f (importedDataConstructors imps))

140 || any (isQualifiedWith mn') (f (importedTypeClasses imps))

138 || any (isQualifiedWith mn') (f (importedTypeClasses imps))

141 || any (isQualifiedWith mn') (f (importedValues imps))

139 || any (isQualifiedWith mn') (f (importedValues imps))

140+ || any (isQualifiedWith mn') (f (importedValueOps imps))

142

141

143 -- Check whether a module name refers to a module that has been imported

142 -- Check whether a module name refers to a module that has been imported

144 -- without qualification into an import scope.

143 -- without qualification into an import scope.

@@ -165,21 +164,35 @@ resolveExports env mn imps exps refs =

165

164

166 -- Looks up an imported type operator and re-qualifies it with the original

165 -- Looks up an imported type operator and re-qualifies it with the original

167 -- module it came from.

166 -- module it came from.

168− resolveTypeOp :: Qualified Ident -> (Ident, ModuleName)

167+ resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName)

168+ resolveTypeOp op

169+ = splitQual

169− resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

170+ . fromMaybe (internalError "Missing value in resolveValue")

170− resolve exportedTypeOps ident

171+ $ resolve exportedTypeOps op

171

172

172 -- Looks up an imported class and re-qualifies it with the original module it

173 -- Looks up an imported class and re-qualifies it with the original module it

173 -- came from.

174 -- came from.

174 resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)

175 resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)

176+ resolveClass className

177+ = splitQual

175− resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

178+ . fromMaybe (internalError "Missing value in resolveClass")

176− resolve exportedTypeClasses className

179+ $ resolve exportedTypeClasses className

177

180

178 -- Looks up an imported value and re-qualifies it with the original module it

181 -- Looks up an imported value and re-qualifies it with the original module it

179 -- came from.

182 -- came from.

180 resolveValue :: Qualified Ident -> (Ident, ModuleName)

183 resolveValue :: Qualified Ident -> (Ident, ModuleName)

184+ resolveValue ident

185+ = splitQual

181− resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

186+ . fromMaybe (internalError "Missing value in resolveValue")

182− resolve exportedValues ident

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

183

196

184 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

197 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

185 resolve f (Qualified (Just mn'') a) = do

198 resolve f (Qualified (Just mn'') a) = do

@@ -200,97 +213,69 @@ resolveExports env mn imps exps refs =

200--

213--

201filterModule

214filterModule

202 :: forall m

215 :: forall m

203− . (MonadError MultipleErrors m)

216+ . MonadError MultipleErrors m

204 => ModuleName

217 => ModuleName

205 -> Exports

218 -> Exports

206 -> [DeclarationRef]

219 -> [DeclarationRef]

207 -> m Exports

220 -> m Exports

208filterModule mn exps refs = do

221filterModule mn exps refs = do

209− types <- foldM (filterTypes $ exportedTypes exps) [] refs

222+ types <- foldM filterTypes [] refs

210− typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs

223+ typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs

211− values <- foldM (filterValues $ exportedValues exps) [] refs

212− classes <- foldM (filterClasses $ exportedTypeClasses exps) [] 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

213− return $ exps

227+ return Exports

214 { exportedTypes = types

228 { exportedTypes = types

215 , exportedTypeOps = typeOps

229 , exportedTypeOps = typeOps

216 , exportedTypeClasses = classes

230 , exportedTypeClasses = classes

217 , exportedValues = values

231 , exportedValues = values

232+ , exportedValueOps = valueOps

218 }

233 }

219

234

220 where

235 where

221

236

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.

227 filterTypes

237 filterTypes

228 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

238 :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

229− -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

230 -> DeclarationRef

239 -> DeclarationRef

231 -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

240 -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

232− filterTypes exps' result (PositionedDeclarationRef pos _ r) =

241+ filterTypes result (PositionedDeclarationRef pos _ r) =

233− rethrowWithPosition pos $ filterTypes exps' result r

242+ rethrowWithPosition pos $ filterTypes result r

234− filterTypes exps' result (TypeRef name expDcons) =

243+ filterTypes result (TypeRef name expDcons) =

235− case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of

244+ case matchType `find` exportedTypes exps of

236− Nothing -> throwError . errorMessage . UnknownExportType $ name

245+ Nothing -> throwError . errorMessage . UnknownExport $ TyName name

237 Just ((_, dcons), _) -> do

246 Just ((_, dcons), _) -> do

238 let expDcons' = fromMaybe dcons expDcons

247 let expDcons' = fromMaybe dcons expDcons

239 traverse_ (checkDcon name dcons) expDcons'

248 traverse_ (checkDcon name dcons) expDcons'

240 return $ ((name, expDcons'), mn) : result

249 return $ ((name, expDcons'), mn) : result

241− filterTypes _ result _ = return result

250+ where

242−

251+ -- Finds a type declaration by matching its name and defining module

252+ matchType ((name', _), mn') = name == name' && mn == mn'

243− -- Ensures a data constructor is exportable for a given type. Takes a type

253+ -- 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

254+ -- name, a list of exportable data constructors for the type, and the name of

245− -- the data constructor to check.

255+ -- the data constructor to check.

246− checkDcon

256+ checkDcon

247− :: ProperName 'TypeName

257+ :: ProperName 'TypeName

248− -> [ProperName 'ConstructorName]

258+ -> [ProperName 'ConstructorName]

249− -> ProperName 'ConstructorName

259+ -> ProperName 'ConstructorName

250− -> m ()

260+ -> m ()

251− checkDcon tcon exps' name =

261+ checkDcon tcon dcons dcon =

252− unless (name `elem` exps') $

262+ unless (dcon `elem` dcons) $

253− throwError . errorMessage $ UnknownExportDataConstructor tcon name

263+ throwError . errorMessage $ UnknownExportDataConstructor tcon dcon

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

264+ filterTypes result _ = return result

267

265

268− -- Takes a list of all the exportable classes, the accumulated list of

266+ filterExport

269− -- filtered exports, and a `DeclarationRef` for an explicit export. When the

267+ :: Eq a

270− -- ref refers to a class in the list of exportable classes, the class is

268+ => (a -> Name)

271− -- included in the result.

269+ -> (DeclarationRef -> Maybe a)

272− filterClasses

273− :: [(ProperName 'ClassName, ModuleName)]

270+ -> (Exports -> [(a, ModuleName)])

274− -> [(ProperName 'ClassName, ModuleName)]

271+ -> [(a, ModuleName)]

275 -> DeclarationRef

272 -> DeclarationRef

276− -> m [(ProperName 'ClassName, ModuleName)]

273+ -> m [(a, ModuleName)]

277− filterClasses exps' result (PositionedDeclarationRef pos _ r) =

274+ filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =

278− rethrowWithPosition pos $ filterClasses exps' result r

275+ rethrowWithPosition pos $ filterExport toName get fromExps result r

279− filterClasses exps' result (TypeClassRef name) =

276+ filterExport toName get fromExps result ref

280− if (name, mn) `elem` exps'

277+ | Just name <- get ref =

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'

278+ if (name, mn) `elem` fromExps exps

294− then return $ (name, mn) : result

279+ then return $ (name, mn) : result

295− else throwError . errorMessage . UnknownExportValue $ name

280+ else throwError . errorMessage . UnknownExport $ toName name

296− filterValues _ result _ = return result

281+ filterExport _ _ _ result _ = return result

src/Language/PureScript/Sugar/Names/Imports.hs+66−122

@@ -1,5 +1,6 @@

1module Language.PureScript.Sugar.Names.Imports

2+ ( ImportDef

2− ( resolveImports

3+ , resolveImports

3 , resolveModuleImport

4 , resolveModuleImport

4 , findImports

5 , findImports

5 ) where

6 ) where

@@ -9,13 +10,10 @@ import Prelude.Compat

9import Control.Arrow (first)

10import Control.Arrow (first)

10import Control.Monad

11import Control.Monad

11import Control.Monad.Error.Class (MonadError(..))

12import Control.Monad.Error.Class (MonadError(..))

12−import Control.Monad.Writer (MonadWriter(..))

13

14−import Data.Foldable (traverse_, for_)

14+import Data.Foldable (for_, traverse_)

15−import Data.Function (on)

16−import Data.List (find, sortBy, groupBy, (\\))

15+import Data.List (find)

17−import Data.Maybe (fromMaybe, isNothing)

16+import Data.Maybe (fromMaybe)

18−import Data.Traversable (for)

19import qualified Data.Map as M

17import qualified Data.Map as M

20import qualified Data.Set as S

18import qualified Data.Set as S

21

19

@@ -25,110 +23,44 @@ import Language.PureScript.Errors

25import Language.PureScript.Names

23import Language.PureScript.Names

26import Language.PureScript.Sugar.Names.Env

24import Language.PureScript.Sugar.Names.Env

27

25

26+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

27+

28-- |

29-- Finds the imports within a module, mapping the imported module name to an optional set of

30-- explicitly imported declarations.

31--

32findImports

33− :: forall m

34− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

35− => [Declaration]

33+ :: [Declaration]

36− -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

34+ -> M.Map ModuleName [ImportDef]

37−findImports = foldM (go Nothing) M.empty

35+findImports = foldl (go Nothing) M.empty

38 where

36 where

39− go pos result (ImportDeclaration mn typ qual) = do

37+ go pos result (ImportDeclaration mn typ qual) =

40 let imp = (pos, typ, qual)

38 let imp = (pos, typ, qual)

41− return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

39+ in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

42− go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d

40+ go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d

43− go _ result _ = return result

41+ go _ result _ = result

44−

45−type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

46

42

47-- |

43-- |

48-- Constructs a set of imports for a module.

44-- Constructs a set of imports for a module.

49--

45--

50resolveImports

46resolveImports

51 :: forall m

47 :: forall m

52− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

48+ . MonadError MultipleErrors m

53 => Env

49 => Env

54 -> Module

50 -> Module

55 -> m (Module, Imports)

51 -> m (Module, Imports)

56resolveImports env (Module ss coms currentModule decls exps) =

52resolveImports env (Module ss coms currentModule decls exps) =

57− warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

53+ rethrow (addHint (ErrorInModule currentModule)) $ do

58−

59− imports <- findImports decls

54+ let 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

55+ imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports

89 scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'

56 scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'

57+ (Module ss coms currentModule decls exps,) <$>

90− resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

58+ 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

127

59

128-- | Constructs a set of imports for a single module import.

60-- | Constructs a set of imports for a single module import.

129resolveModuleImport

61resolveModuleImport

130 :: forall m

62 :: forall m

131− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

63+ . MonadError MultipleErrors m

132 => Env

64 => Env

133 -> Imports

65 -> Imports

134 -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])

66 -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])

@@ -139,7 +71,11 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

139 -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)

71 -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)

140 -> m Imports

72 -> m Imports

141 go ie' (pos, typ, impQual) = do

73 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)

143 let virtualModules = importedVirtualModules ie'

79 let virtualModules = importedVirtualModules ie'

144 ie'' = ie' { importedModules = S.insert mn (importedModules ie')

80 ie'' = ie' { importedModules = S.insert mn (importedModules ie')

145 , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

81 , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

@@ -155,7 +91,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

155--

91--

156resolveImport

92resolveImport

157 :: forall m

93 :: forall m

158− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

94+ . MonadError MultipleErrors m

159 => ModuleName

95 => ModuleName

160 -> Exports

96 -> Exports

161 -> Imports

97 -> Imports

@@ -166,19 +102,14 @@ resolveImport importModule exps imps impQual = resolveByType

166 where

102 where

167

103

168 resolveByType :: Maybe ImportDeclarationType -> m Imports

104 resolveByType :: Maybe ImportDeclarationType -> m Imports

105+ resolveByType Nothing =

169− resolveByType Nothing = importAll (importRef Local)

106+ importAll (importRef Local)

107+ resolveByType (Just Implicit) =

170− resolveByType (Just Implicit) = importAll (importRef FromImplicit)

108+ importAll (importRef FromImplicit)

109+ resolveByType (Just (Explicit refs)) =

171− resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs

110+ checkRefs False refs >> foldM (importRef FromExplicit) imps refs

172− resolveByType (Just (Hiding refs)) = do

111+ resolveByType (Just (Hiding refs)) =

173− imps' <- checkRefs True refs >> importAll (importNonHidden refs)

112+ 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'

182

113

183 -- Check that a 'DeclarationRef' refers to an importable symbol

114 -- Check that a 'DeclarationRef' refers to an importable symbol

184 checkRefs :: Bool -> [DeclarationRef] -> m ()

115 checkRefs :: Bool -> [DeclarationRef] -> m ()

@@ -187,15 +118,17 @@ resolveImport importModule exps imps impQual = resolveByType

187 check (PositionedDeclarationRef pos _ r) =

118 check (PositionedDeclarationRef pos _ r) =

188 rethrowWithPosition pos $ check r

119 rethrowWithPosition pos $ check r

189 check (ValueRef name) =

120 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

191 check (TypeRef name dctors) = do

124 check (TypeRef name dctors) = do

192− checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name

125+ checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name

193 let allDctors = fst `map` allExportedDataConstructors name

126 let allDctors = fst `map` allExportedDataConstructors name

194− maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors

127+ for_ dctors $ traverse_ (checkDctorExists name allDctors)

195 check (TypeOpRef name) =

128 check (TypeOpRef name) =

196− checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name

129+ checkImportExists TyOpName (fst `map` exportedTypeOps exps) name

197 check (TypeClassRef name) =

130 check (TypeClassRef name) =

198− checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

131+ checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name

199 check (ModuleRef name) | isHiding =

132 check (ModuleRef name) | isHiding =

200 throwError . errorMessage $ ImportHidingModule name

133 throwError . errorMessage $ ImportHidingModule name

201 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

134 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

@@ -203,12 +136,14 @@ resolveImport importModule exps imps impQual = resolveByType

203 -- Check that an explicitly imported item exists in the module it is being imported from

136 -- Check that an explicitly imported item exists in the module it is being imported from

204 checkImportExists

137 checkImportExists

205 :: Eq a

138 :: Eq a

206− => (ModuleName -> a -> SimpleErrorMessage)

139+ => (a -> Name)

207 -> [a]

140 -> [a]

208 -> a

141 -> a

209 -> m ()

142 -> m ()

210− checkImportExists unknown exports item =

143+ checkImportExists toName exports item

211− when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

144+ = when (item `notElem` exports)

145+ . throwError . errorMessage

146+ $ UnknownImport importModule (toName item)

212

147

213 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

148 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

214 -- from

149 -- from

@@ -217,7 +152,10 @@ resolveImport importModule exps imps impQual = resolveByType

217 -> [ProperName 'ConstructorName]

152 -> [ProperName 'ConstructorName]

218 -> ProperName 'ConstructorName

153 -> ProperName 'ConstructorName

219 -> m ()

154 -> m ()

155+ checkDctorExists tcon exports dctor

156+ = when (dctor `notElem` exports)

157+ . throwError . errorMessage

220− checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

158+ $ UnknownImportDataConstructor importModule tcon dctor

221

159

222 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

160 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

223 importNonHidden hidden m ref | isHidden ref = return m

161 importNonHidden hidden m ref | isHidden ref = return m

@@ -238,18 +176,22 @@ resolveImport importModule exps imps impQual = resolveByType

238

176

239 -- Import all symbols

177 -- Import all symbols

240 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

178 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

241− importAll importer = do

179+ importAll importer =

242− imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

180+ 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)

181+ >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps)

244− imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps)

182+ >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps)

183+ >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps)

245− foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps)

184+ >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps)

246

185

247 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

186 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

248 importRef prov imp (PositionedDeclarationRef pos _ r) =

187 importRef prov imp (PositionedDeclarationRef pos _ r) =

249− warnAndRethrowWithPosition pos $ importRef prov imp r

188+ rethrowWithPosition pos $ importRef prov imp r

250 importRef prov imp (ValueRef name) = do

189 importRef prov imp (ValueRef name) = do

251 let values' = updateImports (importedValues imp) (exportedValues exps) name prov

190 let values' = updateImports (importedValues imp) (exportedValues exps) name prov

252 return $ imp { importedValues = values' }

191 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' }

253 importRef prov imp (TypeRef name dctors) = do

195 importRef prov imp (TypeRef name dctors) = do

254 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov

196 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov

255 let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

197 let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

@@ -257,7 +199,6 @@ resolveImport importModule exps imps impQual = resolveByType

257 dctorNames :: [ProperName 'ConstructorName]

199 dctorNames :: [ProperName 'ConstructorName]

258 dctorNames = fst `map` exportedDctors

200 dctorNames = fst `map` exportedDctors

259 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

201 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

260− when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

261 let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

202 let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

262 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

203 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

263 importRef prov imp (TypeOpRef name) = do

204 importRef prov imp (TypeOpRef name) = do

@@ -266,10 +207,13 @@ resolveImport importModule exps imps impQual = resolveByType

266 importRef prov imp (TypeClassRef name) = do

207 importRef prov imp (TypeClassRef name) = do

267 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

208 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

268 return $ imp { importedTypeClasses = typeClasses' }

209 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"

270

212

271 -- Find all exported data constructors for a given type

213 -- Find all exported data constructors for a given type

214+ allExportedDataConstructors

215+ :: ProperName 'TypeName

272− allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

216+ -> [(ProperName 'ConstructorName, ModuleName)]

273 allExportedDataConstructors name =

217 allExportedDataConstructors name =

274 case find ((== name) . fst . fst) (exportedTypes exps) of

218 case find ((== name) . fst . fst) (exportedTypes exps) of

275 Nothing -> internalError "Invalid state in allExportedDataConstructors"

219 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/Operators.hs+191−86

@@ -6,8 +6,9 @@

6-- it is necessary to reorder them here.

7--

8module Language.PureScript.Sugar.Operators

9+ ( desugarSignedLiterals

9− ( rebracket

10+ , rebracket

10− , removeSignedLiterals

11+ , checkFixityExports

11 ) where

12 ) where

12

13

13import Prelude.Compat

14import Prelude.Compat

@@ -23,27 +24,43 @@ import Language.PureScript.Sugar.Operators.Types

23import Language.PureScript.Traversals (defS, sndM)

24import Language.PureScript.Traversals (defS, sndM)

24import Language.PureScript.Types

25import Language.PureScript.Types

25

26

26−import Control.Monad ((<=<))

27+import Control.Monad (unless, (<=<))

27import Control.Monad.Error.Class (MonadError(..))

28import Control.Monad.Error.Class (MonadError(..))

28

29

30+import Data.Either (partitionEithers)

31+import Data.Foldable (for_, traverse_)

29import Data.Function (on)

32import Data.Function (on)

30−import Data.Functor.Identity

33+import Data.Functor.Identity (Identity(..), runIdentity)

31−import Data.List (partition, groupBy, sortBy)

34+import Data.List (groupBy, sortBy)

32−import Data.Maybe (mapMaybe)

35+import Data.Maybe (mapMaybe, listToMaybe)

36+import Data.Traversable (for)

33import qualified Data.Map as M

37import qualified Data.Map as M

34

38

35import qualified Language.PureScript.Constants as C

39import qualified Language.PureScript.Constants as C

36

40

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

38

51

39-- |

52-- |

40-- An operator associated with its declaration position, fixity, and the name

53-- An operator associated with its declaration position, fixity, and the name

41-- of the function or data constructor it is an alias for.

54-- of the function or data constructor it is an alias for.

42--

55--

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)

44

59

45-- |

60-- |

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.

47--

64--

48rebracket

65rebracket

49 :: forall m

66 :: forall m

@@ -51,44 +68,45 @@ rebracket

51 => [ExternsFile]

68 => [ExternsFile]

52 -> [Module]

69 -> [Module]

53 -> m [Module]

70 -> m [Module]

54−rebracket externs ms = do

71+rebracket externs modules = do

55− let (typeFixities, valueFixities) = partition isTypeFixity $

72+ let (valueFixities, typeFixities) =

73+ partitionEithers

56− concatMap externsFixities externs ++ concatMap collectFixities ms

74+ $ concatMap externsFixities externs

75+ ++ concatMap collectFixities modules

57

76

58− ensureNoDuplicates' $ valueFixities

77+ ensureNoDuplicates' MultipleValueOpFixities valueFixities

59− ensureNoDuplicates' $ typeFixities

78+ ensureNoDuplicates' MultipleTypeOpFixities typeFixities

60

79

61 let valueOpTable = customOperatorTable' valueFixities

80 let valueOpTable = customOperatorTable' valueFixities

81+ let valueAliased = M.fromList (map makeLookupEntry valueFixities)

62− typeOpTable = customOperatorTable' typeFixities

82+ let typeOpTable = customOperatorTable' typeFixities

63− ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms

83+ let typeAliased = M.fromList (map makeLookupEntry typeFixities)

64

84

65− let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities)

85+ for modules

66− typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities)

67− mapM (renameAliasedOperators valueAliased typeAliased) ms'

86+ $ renameAliasedOperators valueAliased typeAliased

87+ <=< rebracketModule valueOpTable typeOpTable

68

88

69 where

89 where

70

90

71− isTypeFixity :: FixityRecord -> Bool

91+ ensureNoDuplicates'

72− -- Nothing case for FixityAlias can only ever be a value fixity, as it's not

92+ :: Ord op

73− -- possible to define types with operator names aside through aliasing.

93+ => (op -> SimpleErrorMessage)

74− -- TODO: This comment is redundant after 0.9.

75− isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True

76− isTypeFixity _ = False

77−

78− ensureNoDuplicates' :: [FixityRecord] -> m ()

94+ -> [FixityRecord op alias]

95+ -> m ()

79− ensureNoDuplicates' =

96+ ensureNoDuplicates' toError =

80− ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos))

97+ ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos))

81

98

99+ customOperatorTable'

100+ :: [FixityRecord op alias]

82− customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]]

101+ -> [[(Qualified op, Associativity)]]

83− customOperatorTable' =

84− customOperatorTable . map (\(i, _, f, _) -> (i, f))

102+ customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f))

85

103

86− makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias)

104+ makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias)

87− makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

105+ makeLookupEntry (qname, _, _, alias) = (qname, alias)

88

106

89 renameAliasedOperators

107 renameAliasedOperators

90− :: M.Map (Qualified Ident) (Qualified FixityAlias)

108+ :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName)))

91− -> M.Map (Qualified Ident) (Qualified FixityAlias)

109+ -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))

92 -> Module

110 -> Module

93 -> m Module

111 -> m Module

94 renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =

112 renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =

@@ -110,52 +128,51 @@ rebracket externs ms = do

110

128

111 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

129 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

112 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

130 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

131+ goExpr pos (Op op) =

113− goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of

132+ (pos, ) <$> case op `M.lookup` valueAliased of

114− Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias)

133+ Just (Qualified mn' (Left alias)) ->

134+ return $ Var (Qualified mn' alias)

135+ Just (Qualified mn' (Right alias)) ->

115− Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias)

136+ return $ Constructor (Qualified mn' alias)

116− _ -> Var name)

137+ Nothing ->

138+ maybe id rethrowWithPosition pos $

139+ throwError . errorMessage . UnknownName $ fmap ValOpName op

117 goExpr pos other = return (pos, other)

140 goExpr pos other = return (pos, other)

118

141

119 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

142 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

120 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

143 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

121− goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of

144+ goBinder pos (BinaryNoParensBinder (OpBinder op) lhs rhs) =

145+ case op `M.lookup` valueAliased of

122− Just (Qualified _ (AliasValue alias)) ->

146+ Just (Qualified mn' (Left alias)) ->

123− maybe id rethrowWithPosition pos $

147+ maybe id rethrowWithPosition pos $

148+ throwError . errorMessage $

124− throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias

149+ InvalidOperatorInBinder op (Qualified mn' alias)

125− Just (Qualified mn' (AliasConstructor alias)) ->

150+ Just (Qualified mn' (Right alias)) ->

126− return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])

151+ return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])

127− _ ->

152+ Nothing ->

128− maybe id rethrowWithPosition pos $

153+ maybe id rethrowWithPosition pos $

129− throwError . errorMessage $ UnknownValue name

154+ throwError . errorMessage . UnknownName $ fmap ValOpName op

130− goBinder _ (BinaryNoParensBinder {}) =

155+ goBinder _ BinaryNoParensBinder{} =

131 internalError "BinaryNoParensBinder has no OpBinder"

156 internalError "BinaryNoParensBinder has no OpBinder"

132 goBinder pos other = return (pos, other)

157 goBinder pos other = return (pos, other)

133

158

134 goType :: Maybe SourceSpan -> Type -> m Type

159 goType :: Maybe SourceSpan -> Type -> m Type

135− goType pos = everywhereOnTypesM go

160+ goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go

136 where

161 where

137 go :: Type -> m Type

162 go :: Type -> m Type

138− go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of

163+ go (BinaryNoParensType (TypeOp op) lhs rhs) =

164+ case op `M.lookup` typeAliased of

139− Just (Qualified mn' (AliasType alias)) ->

165+ Just alias ->

140− return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs

166+ return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs

141− _ ->

167+ Nothing ->

142− maybe id rethrowWithPosition pos $

143− throwError . errorMessage $ UnknownTypeOp name

168+ throwError . errorMessage $ UnknownName $ fmap TyOpName op

144 go other = return other

169 go other = return other

145

170

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−

154rebracketModule

171rebracketModule

155 :: forall m

172 :: forall m

156 . (MonadError MultipleErrors m)

173 . (MonadError MultipleErrors m)

157− => [[(Qualified Ident, Associativity)]]

174+ => [[(Qualified (OpName 'ValueOpName), Associativity)]]

158− -> [[(Qualified Ident, Associativity)]]

175+ -> [[(Qualified (OpName 'TypeOpName), Associativity)]]

159 -> Module

176 -> Module

160 -> m Module

177 -> m Module

161rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

178rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

@@ -167,7 +184,7 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

167 (goExpr <=< decontextify goExpr')

184 (goExpr <=< decontextify goExpr')

168 goBinder

185 goBinder

169

186

170− (goDecl, goExpr') = updateTypes (\_ -> goType)

187+ (goDecl, goExpr') = updateTypes (const goType)

171

188

172 goExpr :: Expr -> m Expr

189 goExpr :: Expr -> m Expr

173 goExpr = return . matchExprOperators valueOpTable

190 goExpr = return . matchExprOperators valueOpTable

@@ -210,40 +227,61 @@ removeParens = f

210 -> a

227 -> a

211 decontextify ctxf = snd . runIdentity . ctxf Nothing

228 decontextify ctxf = snd . runIdentity . ctxf Nothing

212

229

213−externsFixities

230+externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]

214− :: ExternsFile

215− -> [FixityRecord]

216externsFixities ExternsFile{..} =

231externsFixities ExternsFile{..} =

217− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

232+ map fromFixity efFixities ++ map fromTypeFixity efTypeFixities

218− | ExternsFixity assoc prec op alias <- efFixities

233+ where

219− ]

220

234

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+

221−collectFixities :: Module -> [FixityRecord]

257+collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]

222collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

258collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

223 where

259 where

224− collect :: Declaration -> [FixityRecord]

260+ collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]

225− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

261+ collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) =

226− [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

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)]

227 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

265 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

228 collect _ = []

266 collect _ = []

229

267

230ensureNoDuplicates

268ensureNoDuplicates

231− :: MonadError MultipleErrors m

269+ :: (Ord a, MonadError MultipleErrors m)

270+ => (a -> SimpleErrorMessage)

232− => [(Qualified Ident, SourceSpan)]

271+ -> [(Qualified a, SourceSpan)]

233 -> m ()

272 -> m ()

234−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

273+ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m

235 where

274 where

236 go [] = return ()

275 go [] = return ()

237 go [_] = return ()

276 go [_] = return ()

238− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

277+ go ((x@(Qualified (Just mn) op), _) : (y, pos) : _) | x == y =

239 rethrow (addHint (ErrorInModule mn)) $

278 rethrow (addHint (ErrorInModule mn)) $

240− rethrowWithPosition pos $

279+ rethrowWithPosition pos $ throwError . errorMessage $ toError op

241− throwError . errorMessage $ MultipleFixities name

242 go (_ : rest) = go rest

280 go (_ : rest) = go rest

243

281

244customOperatorTable

282customOperatorTable

245− :: [(Qualified Ident, Fixity)]

283+ :: [(Qualified op, Fixity)]

246− -> [[(Qualified Ident, Associativity)]]

284+ -> [[(Qualified op, Associativity)]]

247customOperatorTable fixities =

285customOperatorTable fixities =

248 let

286 let

249 userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities

287 userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities

@@ -300,3 +338,70 @@ updateTypes goType = (goDecl, goExpr)

300 ty' <- goType' pos ty

338 ty' <- goType' pos ty

301 return (pos, TypedValue check v ty')

339 return (pos, TypedValue check v ty')

302 goExpr pos other = return (pos, other)

340 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

6import Language.PureScript.Names

7import Language.PureScript.Sugar.Operators.Common

8

9−matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder

9+matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder

10matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id

11 where

12

@@ -18,9 +18,9 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id

18 extractOp (BinaryNoParensBinder op l r) = Just (op, l, r)

19 extractOp _ = Nothing

20

21− fromOp :: Binder -> Maybe (Qualified Ident)

21+ fromOp :: Binder -> Maybe (Qualified (OpName 'ValueOpName))

22− fromOp (OpBinder q@(Qualified _ (Op _))) = Just q

22+ fromOp (OpBinder q@(Qualified _ (OpName _))) = Just q

23 fromOp _ = Nothing

24

25− reapply :: Qualified Ident -> Binder -> Binder -> Binder

25+ reapply :: Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder

26 reapply = BinaryNoParensBinder . OpBinder

src/Language/PureScript/Sugar/Operators/Common.hs+11−11

@@ -28,36 +28,36 @@ parseValue :: P.Parsec (Chain a) () a

28parseValue = token (either Just (const Nothing)) P.<?> "expression"

29

30parseOp

31− :: (a -> (Maybe (Qualified Ident)))

31+ :: (a -> (Maybe (Qualified (OpName nameType))))

32− -> P.Parsec (Chain a) () (Qualified Ident)

32+ -> P.Parsec (Chain a) () (Qualified (OpName nameType))

33parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"

34

35matchOp

36− :: (a -> (Maybe (Qualified Ident)))

36+ :: (a -> (Maybe (Qualified (OpName nameType))))

37− -> Qualified Ident

37+ -> Qualified (OpName nameType)

38 -> P.Parsec (Chain a) () ()

39matchOp fromOp op = do

40 ident <- parseOp fromOp

41 guard $ ident == op

42

43opTable

44− :: [[(Qualified Ident, Associativity)]]

44+ :: [[(Qualified (OpName nameType), Associativity)]]

45− -> (a -> Maybe (Qualified Ident))

45+ -> (a -> Maybe (Qualified (OpName nameType)))

46− -> (Qualified Ident -> a -> a -> a)

46+ -> (Qualified (OpName nameType) -> a -> a -> a)

47 -> [[P.Operator (Chain a) () Identity a]]

48opTable ops fromOp reapply =

49 map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops

50 ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]

51

52matchOperators

53− :: forall a

53+ :: forall a nameType

54 . Show a

55 => (a -> Bool)

56 -> (a -> Maybe (a, a, a))

57− -> (a -> Maybe (Qualified Ident))

57+ -> (a -> Maybe (Qualified (OpName nameType)))

58− -> (Qualified Ident -> a -> a -> a)

58+ -> (Qualified (OpName nameType) -> a -> a -> a)

59 -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a)

60− -> [[(Qualified Ident, Associativity)]]

60+ -> [[(Qualified (OpName nameType), Associativity)]]

61 -> a

62 -> a

63matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains

src/Language/PureScript/Sugar/Operators/Expr.hs+6−6

@@ -11,7 +11,7 @@ import Language.PureScript.AST

11import Language.PureScript.Names

12import Language.PureScript.Sugar.Operators.Common

13

14−matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr

14+matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr

15matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

16 where

17

@@ -23,12 +23,12 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

23 extractOp (BinaryNoParens op l r) = Just (op, l, r)

24 extractOp _ = Nothing

25

26− fromOp :: Expr -> Maybe (Qualified Ident)

26+ fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName))

27− fromOp (Var q@(Qualified _ (Op _))) = Just q

27+ fromOp (Op q@(Qualified _ (OpName _))) = Just q

28 fromOp _ = Nothing

29

30− reapply :: Qualified Ident -> Expr -> Expr -> Expr

30+ reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr

31− reapply op t1 t2 = App (App (Var op) t1) t2

31+ reapply op t1 t2 = App (App (Op op) t1) t2

32

33 modOpTable

34 :: [[P.Operator (Chain Expr) () Identity Expr]]

@@ -40,5 +40,5 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

40 parseTicks :: P.Parsec (Chain Expr) () Expr

41 parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

42 where

43− fromOther (Var (Qualified _ (Op _))) = Nothing

43+ fromOther (Op _) = Nothing

44 fromOther v = Just v

src/Language/PureScript/Sugar/Operators/Types.hs+4−4

@@ -7,7 +7,7 @@ import Language.PureScript.Names

7import Language.PureScript.Sugar.Operators.Common

8import Language.PureScript.Types

9

10−matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type

10+matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type

11matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id

12 where

13

@@ -19,9 +19,9 @@ matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id

19 extractOp (BinaryNoParensType op l r) = Just (op, l, r)

20 extractOp _ = Nothing

21

22− fromOp :: Type -> Maybe (Qualified Ident)

22+ fromOp :: Type -> Maybe (Qualified (OpName 'TypeOpName))

23− fromOp (TypeOp q@(Qualified _ (Op _))) = Just q

23+ fromOp (TypeOp q@(Qualified _ (OpName _))) = Just q

24 fromOp _ = Nothing

25

26− reapply :: Qualified Ident -> Type -> Type -> Type

26+ reapply :: Qualified (OpName 'TypeOpName) -> Type -> Type -> Type

27 reapply = BinaryNoParensType . TypeOp

src/Language/PureScript/Sugar/TypeClasses.hs+1−1

@@ -269,7 +269,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

269

270 -- Lookup the type arguments and member types for the type class

271 (args, implies, tyDecls) <-

272− maybe (throwError . errorMessage $ UnknownTypeClass className) return $

272+ maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $

273 M.lookup (qualify mn className) m

274

275 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

8

9import Prelude.Compat

10

11−import Control.Monad (forM)

12import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Error.Class (MonadError(..))

13

12

14import Language.PureScript.AST

13import Language.PureScript.AST

@@ -20,38 +19,45 @@ import Language.PureScript.Traversals

20-- |

19-- |

21-- Replace all top level type declarations in a module with type annotations

20-- Replace all top level type declarations in a module with type annotations

22--

21--

23−desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]

22+desugarTypeDeclarationsModule

23+ :: forall m

24+ . MonadError MultipleErrors m

25+ => Module

26+ -> m Module

24−desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

27+desugarTypeDeclarationsModule (Module ss coms name ds exps) =

25 rethrow (addHint (ErrorInModule name)) $

28 rethrow (addHint (ErrorInModule name)) $

26 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

29 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

27 where

30 where

28

31

29 desugarTypeDeclarations :: [Declaration] -> m [Declaration]

32 desugarTypeDeclarations :: [Declaration] -> m [Declaration]

30− desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

33+ desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do

31− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

34+ (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest)

32− return (PositionedDeclaration pos com d' : ds')

35+ return (PositionedDeclaration pos com d' : rest')

33− desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

36+ desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do

34 (_, nameKind, val) <- fromValueDeclaration d

37 (_, 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)

36 where

39 where

37 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

40 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)

39 fromValueDeclaration (PositionedDeclaration pos com d') = do

43 fromValueDeclaration (PositionedDeclaration pos com d') = do

40 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

44 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

41 return (ident, nameKind, PositionedValue pos com val)

45 return (ident, nameKind, PositionedValue pos com val)

46+ fromValueDeclaration _ =

42− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

47+ throwError . errorMessage $ OrphanTypeDeclaration name'

48+ desugarTypeDeclarations [TypeDeclaration name' _] =

43− desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

49+ throwError . errorMessage $ OrphanTypeDeclaration name'

44− desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

50+ desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do

45 let (_, f, _) = everywhereOnValuesTopDownM return go return

51 let (_, f, _) = everywhereOnValuesTopDownM return go return

46 f' (Left gs) = Left <$> mapM (pairM return f) gs

52 f' (Left gs) = Left <$> mapM (pairM return f) gs

47 f' (Right v) = Right <$> f v

53 f' (Right v) = Right <$> f v

48− (:) <$> (ValueDeclaration name nameKind bs <$> f' val)

54+ (:) <$> (ValueDeclaration name' nameKind bs <$> f' val)

49 <*> desugarTypeDeclarations rest

55 <*> desugarTypeDeclarations rest

50 where

56 where

51− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

57+ go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val'

52 go other = return other

58 go other = return other

53− desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) =

59+ desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) =

54− (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds)

60+ (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds')

55 <*> desugarTypeDeclarations rest

61 <*> desugarTypeDeclarations rest

56− desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

62+ desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest

57 desugarTypeDeclarations [] = return []

63 desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker.hs+17−67

@@ -183,7 +183,7 @@ typeCheckAll

183 -> [DeclarationRef]

184 -> [Declaration]

185 -> m [Declaration]

186−typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

186+typeCheckAll moduleName _ = traverse go

187 where

188 go :: Declaration -> m Declaration

189 go (DataDeclaration dtype name args dctors) = do

@@ -223,7 +223,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

223 let args' = args `withKinds` kind

224 addTypeSynonym moduleName name args' ty kind

225 return $ TypeSynonymDeclaration name args ty

226+ go TypeDeclaration{} =

226− go TypeDeclaration{} = internalError "Type declarations should have been removed"

227+ internalError "Type declarations should have been removed before typeCheckAlld"

227 go (ValueDeclaration name nameKind [] (Right val)) = do

228 go (ValueDeclaration name nameKind [] (Right val)) = do

228 env <- getEnv

229 env <- getEnv

229 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

230 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

@@ -261,9 +262,9 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

261 Just _ -> throwError . errorMessage $ RedefinedIdent name

262 Just _ -> throwError . errorMessage $ RedefinedIdent name

262 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

263 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

263 return d

264 return d

264− go (d@FixityDeclaration{}) = return d

265+ go d@FixityDeclaration{} = return d

265− go (d@ImportDeclaration{}) = return d

266+ go d@ImportDeclaration{} = return d

266− go (d@(TypeClassDeclaration pn args implies tys)) = do

267+ go d@(TypeClassDeclaration pn args implies tys) = do

267 addTypeClass moduleName pn args implies tys

268 addTypeClass moduleName pn args implies tys

268 return d

269 return d

269 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

270 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

277 go (PositionedDeclaration pos com d) =

278 go (PositionedDeclaration pos com d) =

278 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

279 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

279

280

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−

297 checkInstanceMembers :: [Declaration] -> m [Declaration]

281 checkInstanceMembers :: [Declaration] -> m [Declaration]

298 checkInstanceMembers instDecls = do

282 checkInstanceMembers instDecls = do

299 let idents = sort . map head . group . map memberName $ instDecls

283 let idents = sort . map head . group . map memberName $ instDecls

@@ -348,16 +332,17 @@ typeCheckModule

348 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

332 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

349 => Module

333 => Module

350 -> m Module

334 -> m Module

335+typeCheckModule (Module _ _ _ _ Nothing) =

351−typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

336+ internalError "exports should have been elaborated before typeCheckModule"

352−typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

337+typeCheckModule (Module ss coms mn decls (Just exps)) =

338+ warnAndRethrow (addHint (ErrorInModule mn)) $ do

353− modify (\s -> s { checkCurrentModule = Just mn })

339+ modify (\s -> s { checkCurrentModule = Just mn })

354− decls' <- typeCheckAll mn exps decls

340+ decls' <- typeCheckAll mn exps decls

355− for_ exps $ \e -> do

341+ for_ exps $ \e -> do

356− checkTypesAreExported e

342+ checkTypesAreExported e

357− checkClassMembersAreExported e

343+ checkClassMembersAreExported e

358− checkClassesAreExported e

344+ checkClassesAreExported e

359− checkNonAliasesAreExported (exportedDataConstructors exps) e

360− return $ Module ss coms mn decls' (Just exps)

345+ return $ Module ss coms mn decls' (Just exps)

361 where

346 where

362

347

363 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()

348 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()

@@ -436,38 +421,3 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

436 extractMemberName (TypeDeclaration memberName _) = memberName

421 extractMemberName (TypeDeclaration memberName _) = memberName

437 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

422 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

438 checkClassMembersAreExported _ = return ()

423 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

239 go (TypeConstructor v) = do

240 env <- getEnv

241 case M.lookup v (types env) of

242− Nothing -> throwError . errorMessage $ UnknownTypeConstructor v

242+ Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v

243 Just (kind, _) -> return kind

244 go (TypeApp t1 t2) = do

245 k0 <- freshKind

src/Language/PureScript/TypeChecker/Types.hs+3−3

@@ -293,7 +293,7 @@ infer' (Var var) = do

293infer' v@(Constructor c) = do

294 env <- getEnv

295 case M.lookup c (dataConstructors env) of

296− Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

296+ Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

297 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

298 return $ TypedValue True v' ty'

299infer' (Case vals binders) = do

@@ -391,7 +391,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

391 unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor

392 unifyTypes ret val

393 M.unions <$> zipWithM inferBinder (reverse args) binders

394− _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing

394+ _ -> throwError . errorMessage . UnknownName . fmap DctorName $ ctor

395 where

396 peelArgs :: Type -> ([Type], Type)

397 peelArgs = go []

@@ -640,7 +640,7 @@ check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop

640check' v@(Constructor c) ty = do

641 env <- getEnv

642 case M.lookup c (dataConstructors env) of

643− Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

643+ Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

644 Just (_, _, ty1, _) -> do

645 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

646 mv <- subsumes (Just v) repl ty

src/Language/PureScript/Types.hs+1−2

@@ -49,7 +49,7 @@ data Type

49 -- A type operator. This will be desugared into a type constructor during the

50 -- "operators" phase of desugaring.

51 --

52− | TypeOp (Qualified Ident)

52+ | TypeOp (Qualified (OpName 'TypeOpName))

53 -- |

54 -- A type application

55 --

@@ -78,7 +78,6 @@ data Type

78 -- A type with a kind annotation

79 --

80 | KindedType Type Kind

81− --

82 -- |

81 -- |

83 -- A placeholder used in pretty printing

82 -- A placeholder used in pretty printing

84 --

83 --

tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs+1−1

@@ -16,7 +16,7 @@ setup = do

16 Integration.deleteOutputFolder

17 s <- Integration.compileTestProject

18 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

20 _ <- Integration.startServer

21 mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"]

22

tests/Language/PureScript/Ide/ImportsSpec.hs+3−1

@@ -69,6 +69,8 @@ spec = do

69 let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i

70 addValueImport i mn is =

71 prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is)

72+ addOpImport op mn is =

73+ prettyPrintImportSection (addExplicitImport' (FixityDeclaration op) mn is)

72 addDtorImport i t mn is =

74 addDtorImport i t mn is =

73 prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is)

75 prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is)

74 it "adds an implicit unqualified import" $

76 it "adds an implicit unqualified import" $

@@ -96,7 +98,7 @@ spec = do

96 ]

98 ]

97 it "adds an operator to an explicit import list" $

99 it "adds an operator to an explicit import list" $

98 shouldBe

100 shouldBe

99− (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)

101+ (addOpImport (Left (P.OpName "<~>")) (P.moduleNameFromString "Data.Array") explicitImports)

100 [ "import Prelude"

102 [ "import Prelude"

101 , "import Data.Array ((<~>), tail)"

103 , "import Data.Array ((<~>), tail)"

102 ]

104 ]

tests/TestDocs.hs−5

@@ -270,11 +270,6 @@ testCases =

270 , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"

271 ])

272

273− -- Remove this after 0.9.

274− , ("OldOperators",

275− [ ShouldBeDocumented (n "OldOperators2") "(>>)" []

276− ])

277−

278 , ("NewOperators",

273 , ("NewOperators",

279 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

274 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

280 ])

275 ])