5962d9f · rowtype-yoga/purescript-native

examples/passing/2018.pursnew file+25

compare with golang

unifiedsplit

@@ -0,0 +1,25 @@

1+module B where

2+

3+ data Foo = X | Y

4+

5+module A where

6+

7+ import B as Main

8+

9+ -- Prior to the 2018 fix this would be detected as a cycle between A and Main.

10+ foo ∷ Main.Foo → Main.Foo

11+ foo x = x

12+

13+module Main where

14+

15+import Prelude

16+import A (foo)

17+import B (Foo(..))

18+import Control.Monad.Eff (Eff)

19+import Control.Monad.Eff.Console (CONSOLE, log)

20+

21+main :: forall e. Eff (console :: CONSOLE | e) Unit

22+main = do

23+ let tmp = foo X

24+ log "Done"

25+

examples/passing/CaseInputWildcard.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff (Eff)

5+import Control.Monad.Eff.Console (log, CONSOLE)

6+

7+data Foo = X | Y

8+

9+what ∷ Foo → Int → Boolean → Foo

10+what x = case _, x, _ of

11+ 0, X, true → X

12+ 0, Y, true → X

13+ _, _, _ → Y

14+

15+main :: forall e. Eff (console :: CONSOLE | e) Unit

16+main = do

17+ let tmp = what Y 0 true

18+ log "Done"

examples/passing/DctorOperatorAlias.purs+5

@@ -11,9 +11,14 @@ module Main where

11 import Control.Monad.Eff.Console (CONSOLE, log)

12 import Test.Assert (ASSERT, assert')

13 import Data.List (List(..), (:))

14+ import Data.List as L

14

15

16+ -- unqualified

15 infixl 6 Cons as !

17 infixl 6 Cons as !

16

18

19+ -- qualified

20+ infixl 6 L.Cons as !!

21+

17 get1 ∷ ∀ a. a → List a → a

22 get1 ∷ ∀ a. a → List a → a

18 get1 y xs = case xs of

23 get1 y xs = case xs of

19 _ : x : _ → x

24 _ : x : _ → x

examples/passing/IfWildcard.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff (Eff)

5+import Control.Monad.Eff.Console (log, CONSOLE)

6+

7+data Foo = X | Y

8+

9+cond ∷ ∀ a. Boolean → a → a → a

10+cond = if _ then _ else _

11+

12+what ∷ Boolean → Foo

13+what = if _ then X else Y

14+

15+main :: forall e. Eff (console :: CONSOLE | e) Unit

16+main = do

17+ let tmp1 = what true

18+ tmp2 = cond true 0 1

19+ log "Done"

examples/passing/TypeOperators.pursnew file+34

@@ -0,0 +1,34 @@

1+module A

2+ ( Tuple(..)

3+ , type (/\)

4+ , (/\)

5+ , Natural

6+ , type (~>)

7+ ) where

8+

9+ data Tuple a b = Tuple a b

10+

11+ infixl 6 Tuple as /\

12+ infixl 6 type Tuple as /\

13+

14+ type Natural f g = ∀ a. f a → g a

15+

16+ infixr 0 type Natural as ~>

17+

18+ tup ∷ ∀ a b. a → b → b /\ a

19+ tup a b = b /\ a

20+

21+ tupX ∷ ∀ a b c. a /\ b /\ c → c

22+ tupX (a /\ b /\ c) = c

23+

24+module Main where

25+

26+ import A (type (~>), type (/\), (/\))

27+

28+ natty ∷ ∀ f. f ~> f

29+ natty x = x

30+

31+ swap ∷ ∀ a b. a /\ b → b /\ a

32+ swap (a /\ b) = b /\ a

33+

34+ main = Control.Monad.Eff.Console.log "Done"

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

@@ -125,7 +125,7 @@ startServer port env = withSocketsDo $ do

125 case decodeT cmd of

126 Just cmd' -> do

127 result <- runExceptT (handleCommand cmd')

128− $(logDebug) ("Answer was: " <> T.pack (show result))

128+ -- $(logDebug) ("Answer was: " <> T.pack (show result))

129 liftIO (hFlush stdout)

130 case result of

131 -- What function can I use to clean this up?

psc-ide-server/PROTOCOL.md+24

@@ -240,6 +240,30 @@ Example:

240}

241```

242

243+### Rebuild

244+

245+The `rebuild` command provides a fast rebuild for a single module. It doesn't

246+recompile the entire project though. All the modules dependencies need to be

247+loaded.

248+

249+Arguments:

250+- `file :: String` the path to the module to rebuild

251+

252+```json

253+{

254+ "command": "rebuild",

255+ "params": {

256+ "file": "/path/to/file.purs"

257+ }

258+}

259+```

260+

261+**Result**

262+

263+In the Success case you get a list of warnings in the compilers json format.

264+

265+In the Error case you get the errors in the compilers json format

266+

243### Pursuit

267### Pursuit

244The `pursuit` command looks up the packages/completions for a given identifier from Pursuit.

268The `pursuit` command looks up the packages/completions for a given identifier from Pursuit.

245

269

psc/Main.hs+1−2

@@ -28,8 +28,7 @@ import qualified Language.PureScript as P

28import qualified Paths_purescript as Paths

29

30import Language.PureScript.Make

31−

32−import JSON

31+import Language.PureScript.Errors.JSON

33

32

34data PSCMakeOptions = PSCMakeOptions

33data PSCMakeOptions = PSCMakeOptions

35 { pscmInput :: [FilePath]

34 { pscmInput :: [FilePath]

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.ValueRef ident) = N.runIdent ident

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

257− showRef (P.TypeClassRef pn) = N.runProperName pn

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

258 showRef (P.ProperRef pn) = pn

259 showRef (P.ProperRef pn) = 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

purescript.cabal+7−1

@@ -37,6 +37,8 @@ extra-source-files: examples/passing/*.purs

37 , tests/support/flattened/*.js

38 , tests/support/psci/*.purs

39 , tests/support/pscide/src/*.purs

40+ , tests/support/pscide/src/*.js

41+ , tests/support/pscide/src/*.fail

40 , stack.yaml

42 , stack.yaml

41 , stack-lts-5.yaml

43 , stack-lts-5.yaml

42 , stack-nightly.yaml

44 , stack-nightly.yaml

@@ -143,6 +145,7 @@ library

143 Language.PureScript.Comments

145 Language.PureScript.Comments

144 Language.PureScript.Environment

146 Language.PureScript.Environment

145 Language.PureScript.Errors

147 Language.PureScript.Errors

148+ Language.PureScript.Errors.JSON

146 Language.PureScript.Kinds

149 Language.PureScript.Kinds

147 Language.PureScript.Linter

150 Language.PureScript.Linter

148 Language.PureScript.Linter.Exhaustive

151 Language.PureScript.Linter.Exhaustive

@@ -179,6 +182,7 @@ library

179 Language.PureScript.Sugar.Operators.Common

182 Language.PureScript.Sugar.Operators.Common

180 Language.PureScript.Sugar.Operators.Expr

183 Language.PureScript.Sugar.Operators.Expr

181 Language.PureScript.Sugar.Operators.Binders

184 Language.PureScript.Sugar.Operators.Binders

185+ Language.PureScript.Sugar.Operators.Types

182 Language.PureScript.Sugar.TypeClasses

186 Language.PureScript.Sugar.TypeClasses

183 Language.PureScript.Sugar.TypeClasses.Deriving

187 Language.PureScript.Sugar.TypeClasses.Deriving

184 Language.PureScript.Sugar.TypeDeclarations

188 Language.PureScript.Sugar.TypeDeclarations

@@ -230,6 +234,7 @@ library

230 Language.PureScript.Ide.Reexports

234 Language.PureScript.Ide.Reexports

231 Language.PureScript.Ide.Imports

235 Language.PureScript.Ide.Imports

232 Language.PureScript.Ide.Util

236 Language.PureScript.Ide.Util

237+ Language.PureScript.Ide.Rebuild

233

238

234 Control.Monad.Logger

239 Control.Monad.Logger

235 Control.Monad.Supply

240 Control.Monad.Supply

@@ -253,7 +258,7 @@ executable psc

253 main-is: Main.hs

258 main-is: Main.hs

254 buildable: True

259 buildable: True

255 hs-source-dirs: psc

260 hs-source-dirs: psc

256− other-modules: JSON, Paths_purescript

261+ other-modules: Paths_purescript

257 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

262 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

258

263

259executable psci

264executable psci

@@ -397,6 +402,7 @@ test-suite tests

397 Language.PureScript.Ide.Imports.IntegrationSpec

402 Language.PureScript.Ide.Imports.IntegrationSpec

398 Language.PureScript.Ide.Integration

403 Language.PureScript.Ide.Integration

399 Language.PureScript.Ide.MatcherSpec

404 Language.PureScript.Ide.MatcherSpec

405+ Language.PureScript.Ide.RebuildSpec

400 Language.PureScript.Ide.ReexportsSpec

406 Language.PureScript.Ide.ReexportsSpec

401 Language.PureScript.IdeSpec

407 Language.PureScript.IdeSpec

402 PSCi.Completion

408 PSCi.Completion

src/Language/PureScript/AST/Declarations.hs+23−1

@@ -62,6 +62,10 @@ data DeclarationRef

62 --

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

64 -- |

65+ -- A type operator

66+ --

67+ | TypeOpRef Ident

68+ -- |

65 -- A value

69 -- A value

66 --

70 --

67 | ValueRef Ident

71 | ValueRef Ident

@@ -89,6 +93,7 @@ data DeclarationRef

89

93

90instance Eq DeclarationRef where

94instance Eq DeclarationRef where

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

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

96+ (TypeOpRef name) == (TypeOpRef name') = name == name'

92 (ValueRef name) == (ValueRef name') = name == name'

97 (ValueRef name) == (ValueRef name') = name == name'

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

98 (TypeClassRef name) == (TypeClassRef name') = name == name'

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

99 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

@@ -190,7 +195,7 @@ data Declaration

190 -- |

195 -- |

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

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

192 --

197 --

193− | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))

198+ | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias))

194 -- |

199 -- |

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

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

196 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

201 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

@@ -211,6 +216,22 @@ data Declaration

211 | PositionedDeclaration SourceSpan [Comment] Declaration

216 | PositionedDeclaration SourceSpan [Comment] Declaration

212 deriving (Show, Read)

217 deriving (Show, Read)

213

218

219+data FixityAlias

220+ = AliasValue Ident

221+ | AliasConstructor (ProperName 'ConstructorName)

222+ | AliasType (ProperName 'TypeName)

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

224+

225+foldFixityAlias

226+ :: (Ident -> a)

227+ -> (ProperName 'ConstructorName -> a)

228+ -> (ProperName 'TypeName -> a)

229+ -> FixityAlias

230+ -> a

231+foldFixityAlias f _ _ (AliasValue name) = f name

232+foldFixityAlias _ g _ (AliasConstructor name) = g name

233+foldFixityAlias _ _ h (AliasType name) = h name

234+

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

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

215data TypeInstanceBody

236data TypeInstanceBody

216 -- | This is a derived instance

237 -- | This is a derived instance

@@ -453,3 +474,4 @@ data DoNotationElement

453

474

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

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

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

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

477+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias)

src/Language/PureScript/AST/Exported.hs+4−1

@@ -127,7 +127,6 @@ isExported (Just exps) decl = any (matches decl) exps

127 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

128 matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

129 matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

130− matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident'

131 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

130 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

132 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

131 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

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

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

@@ -136,6 +135,10 @@ isExported (Just exps) decl = any (matches decl) exps

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

135 matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'

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

136 matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'

138

137

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

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

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

141+

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

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

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

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

141 matches _ _ = False

144 matches _ _ = False

src/Language/PureScript/CoreFn/Desugar.hs+7−5

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

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

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

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

75− declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

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

76− let meta = either getValueMeta (Just . getConstructorMeta) alias

76+ let meta = getValueMeta (Qualified mn' name')

77− alias' = either id (fmap properToIdent) alias

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

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

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

79+ let meta = Just $ getConstructorMeta (Qualified mn' name')

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

79 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

81 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

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

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

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

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

@@ -208,7 +210,7 @@ findQualModules decls =

208 where

210 where

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

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

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

212 fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

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

213+ fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q

212 fqDecls _ = []

214 fqDecls _ = []

213

215

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

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

src/Language/PureScript/Docs/Render.hs+10−8

@@ -61,20 +61,22 @@ renderDeclarationWithOptions opts Declaration{..} =

61 AliasDeclaration for (P.Fixity associativity precedence) ->

62 [ keywordFixity associativity

63 , syntax $ show precedence

64− , ident $

64+ , ident $ renderAlias for

65− either

66− (P.showQualified P.runIdent . dequalifyCurrentModule)

67− (P.showQualified P.runProperName . dequalifyCurrentModule)

68− for

69 , keyword "as"

65 , keyword "as"

70 , ident . tail . init $ declTitle

66 , ident . tail . init $ declTitle

71 ]

67 ]

72

68

73 where

69 where

74 renderType' = renderTypeWithOptions opts

70 renderType' = renderTypeWithOptions opts

75− dequalifyCurrentModule (P.Qualified mn a)

71+ renderAlias (P.Qualified mn alias)

76− | mn == currentModule opts = P.Qualified Nothing a

72+ | mn == currentModule opts =

73+ P.foldFixityAlias P.runIdent P.runProperName P.runProperName alias

77− | otherwise = P.Qualified mn a

74+ | otherwise =

75+ P.foldFixityAlias

76+ (P.showQualified P.runIdent . P.Qualified mn)

77+ (P.showQualified P.runProperName . P.Qualified mn)

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

79+ alias

78

80

79renderChildDeclaration :: ChildDeclaration -> RenderedCode

81renderChildDeclaration :: ChildDeclaration -> RenderedCode

80renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

82renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

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

@@ -133,7 +133,7 @@ data DeclarationInfo

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

134 -- operator's fixity.

135 --

136− | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity

136+ | AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity

137 deriving (Show, Eq, Ord)

138

139declInfoToString :: DeclarationInfo -> String

@@ -411,7 +411,7 @@ asDeclarationInfo = do

411 other ->

412 throwCustomError (InvalidDeclarationType other)

413

414−asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))

414+asAliasFor :: Parse e (P.Qualified P.FixityAlias)

415asAliasFor = fromAesonParser

416

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

src/Language/PureScript/Errors.hs+30−2

@@ -46,6 +46,7 @@ data SimpleErrorMessage

46 | UnnecessaryFFIModule ModuleName FilePath

47 | MissingFFIImplementations ModuleName [Ident]

48 | UnusedFFIImplementations ModuleName [Ident]

49+ | InvalidFFIIdentifier ModuleName String

49 | CannotGetFileInfo FilePath

50 | CannotGetFileInfo FilePath

50 | CannotReadFile FilePath

51 | CannotReadFile FilePath

51 | CannotWriteFile FilePath

52 | CannotWriteFile FilePath

@@ -59,12 +60,15 @@ data SimpleErrorMessage

59 | OverlappingNamesInLet

60 | OverlappingNamesInLet

60 | UnknownModule ModuleName

61 | UnknownModule ModuleName

61 | UnknownType (Qualified (ProperName 'TypeName))

62 | UnknownType (Qualified (ProperName 'TypeName))

63+ | UnknownTypeOp (Qualified Ident)

62 | UnknownTypeClass (Qualified (ProperName 'ClassName))

64 | UnknownTypeClass (Qualified (ProperName 'ClassName))

63 | UnknownValue (Qualified Ident)

65 | UnknownValue (Qualified Ident)

64 | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

66 | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

65 | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

67 | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

66 | UnknownImportType ModuleName (ProperName 'TypeName)

68 | UnknownImportType ModuleName (ProperName 'TypeName)

67 | UnknownExportType (ProperName 'TypeName)

69 | UnknownExportType (ProperName 'TypeName)

70+ | UnknownImportTypeOp ModuleName Ident

71+ | UnknownExportTypeOp Ident

68 | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

72 | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

69 | UnknownExportTypeClass (ProperName 'ClassName)

73 | UnknownExportTypeClass (ProperName 'ClassName)

70 | UnknownImportValue ModuleName Ident

74 | UnknownImportValue ModuleName Ident

@@ -83,6 +87,7 @@ data SimpleErrorMessage

83 | DuplicateModuleName ModuleName

87 | DuplicateModuleName ModuleName

84 | DuplicateClassExport (ProperName 'ClassName)

88 | DuplicateClassExport (ProperName 'ClassName)

85 | DuplicateValueExport Ident

89 | DuplicateValueExport Ident

90+ | DuplicateTypeOpExport Ident

86 | DuplicateTypeArgument String

91 | DuplicateTypeArgument String

87 | InvalidDoBind

92 | InvalidDoBind

88 | InvalidDoLet

93 | InvalidDoLet

@@ -229,6 +234,7 @@ errorCode em = case unwrapErrorMessage em of

229 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

234 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

230 MissingFFIImplementations{} -> "MissingFFIImplementations"

235 MissingFFIImplementations{} -> "MissingFFIImplementations"

231 UnusedFFIImplementations{} -> "UnusedFFIImplementations"

236 UnusedFFIImplementations{} -> "UnusedFFIImplementations"

237+ InvalidFFIIdentifier{} -> "InvalidFFIIdentifier"

232 CannotGetFileInfo{} -> "CannotGetFileInfo"

238 CannotGetFileInfo{} -> "CannotGetFileInfo"

233 CannotReadFile{} -> "CannotReadFile"

239 CannotReadFile{} -> "CannotReadFile"

234 CannotWriteFile{} -> "CannotWriteFile"

240 CannotWriteFile{} -> "CannotWriteFile"

@@ -242,12 +248,15 @@ errorCode em = case unwrapErrorMessage em of

242 OverlappingNamesInLet -> "OverlappingNamesInLet"

248 OverlappingNamesInLet -> "OverlappingNamesInLet"

243 UnknownModule{} -> "UnknownModule"

249 UnknownModule{} -> "UnknownModule"

244 UnknownType{} -> "UnknownType"

250 UnknownType{} -> "UnknownType"

251+ UnknownTypeOp{} -> "UnknownTypeOp"

245 UnknownTypeClass{} -> "UnknownTypeClass"

252 UnknownTypeClass{} -> "UnknownTypeClass"

246 UnknownValue{} -> "UnknownValue"

253 UnknownValue{} -> "UnknownValue"

247 UnknownDataConstructor{} -> "UnknownDataConstructor"

254 UnknownDataConstructor{} -> "UnknownDataConstructor"

248 UnknownTypeConstructor{} -> "UnknownTypeConstructor"

255 UnknownTypeConstructor{} -> "UnknownTypeConstructor"

249 UnknownImportType{} -> "UnknownImportType"

256 UnknownImportType{} -> "UnknownImportType"

257+ UnknownImportTypeOp{} -> "UnknownImportTypeOp"

250 UnknownExportType{} -> "UnknownExportType"

258 UnknownExportType{} -> "UnknownExportType"

259+ UnknownExportTypeOp{} -> "UnknownExportTypeOp"

251 UnknownImportTypeClass{} -> "UnknownImportTypeClass"

260 UnknownImportTypeClass{} -> "UnknownImportTypeClass"

252 UnknownExportTypeClass{} -> "UnknownExportTypeClass"

261 UnknownExportTypeClass{} -> "UnknownExportTypeClass"

253 UnknownImportValue{} -> "UnknownImportValue"

262 UnknownImportValue{} -> "UnknownImportValue"

@@ -266,6 +275,7 @@ errorCode em = case unwrapErrorMessage em of

266 DuplicateModuleName{} -> "DuplicateModuleName"

275 DuplicateModuleName{} -> "DuplicateModuleName"

267 DuplicateClassExport{} -> "DuplicateClassExport"

276 DuplicateClassExport{} -> "DuplicateClassExport"

268 DuplicateValueExport{} -> "DuplicateValueExport"

277 DuplicateValueExport{} -> "DuplicateValueExport"

278+ DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"

269 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

279 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

270 InvalidDoBind -> "InvalidDoBind"

280 InvalidDoBind -> "InvalidDoBind"

271 InvalidDoLet -> "InvalidDoLet"

281 InvalidDoLet -> "InvalidDoLet"

@@ -552,6 +562,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

552 paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "

562 paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "

553 , indent . paras $ map (line . runIdent) idents

563 , indent . paras $ map (line . runIdent) idents

554 ]

564 ]

565+ renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =

566+ paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":"

567+ , indent . paras $

568+ [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript."

569+ , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."

570+ ]

571+ ]

555 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

572 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

556 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

573 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

557 , indent . paras $ map line paths

574 , indent . paras $ map line paths

@@ -586,6 +603,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

586 line $ "Unknown module " ++ runModuleName mn

603 line $ "Unknown module " ++ runModuleName mn

587 renderSimpleErrorMessage (UnknownType name) =

604 renderSimpleErrorMessage (UnknownType name) =

588 line $ "Unknown type " ++ showQualified runProperName name

605 line $ "Unknown type " ++ showQualified runProperName name

606+ renderSimpleErrorMessage (UnknownTypeOp name) =

607+ line $ "Unknown type operator " ++ showQualified showIdent name

589 renderSimpleErrorMessage (UnknownTypeClass name) =

608 renderSimpleErrorMessage (UnknownTypeClass name) =

590 line $ "Unknown type class " ++ showQualified runProperName name

609 line $ "Unknown type class " ++ showQualified runProperName name

591 renderSimpleErrorMessage (UnknownValue name) =

610 renderSimpleErrorMessage (UnknownValue name) =

@@ -600,6 +619,12 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

600 ]

619 ]

601 renderSimpleErrorMessage (UnknownExportType name) =

620 renderSimpleErrorMessage (UnknownExportType name) =

602 line $ "Cannot export unknown type " ++ runProperName name

621 line $ "Cannot export unknown type " ++ runProperName name

622+ renderSimpleErrorMessage (UnknownImportTypeOp mn name) =

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

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

625+ ]

626+ renderSimpleErrorMessage (UnknownExportTypeOp name) =

627+ line $ "Cannot export unknown type operator " ++ showIdent name

603 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

628 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

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

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

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

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

@@ -649,6 +674,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

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

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

650 renderSimpleErrorMessage (DuplicateValueExport nm) =

675 renderSimpleErrorMessage (DuplicateValueExport nm) =

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

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

677+ renderSimpleErrorMessage (DuplicateTypeOpExport nm) =

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

652 renderSimpleErrorMessage (CycleInDeclaration nm) =

679 renderSimpleErrorMessage (CycleInDeclaration nm) =

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

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

654 renderSimpleErrorMessage (CycleInModules mns) =

681 renderSimpleErrorMessage (CycleInModules mns) =

@@ -987,8 +1014,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

987

1014

988 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

1015 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

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

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

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

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

991− ]

1018+ ]

992

1019

993 renderSimpleErrorMessage DeprecatedRequirePath =

1020 renderSimpleErrorMessage DeprecatedRequirePath =

994 line "The require-path option is deprecated and will be removed in PureScript 0.9."

1021 line "The require-path option is deprecated and will be removed in PureScript 0.9."

@@ -1196,6 +1223,7 @@ prettyPrintRef :: DeclarationRef -> String

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

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

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

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

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

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

1226+prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident

1199prettyPrintRef (ValueRef ident) = showIdent ident

1227prettyPrintRef (ValueRef ident) = showIdent ident

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

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

1201prettyPrintRef (ProperRef name) = name

1229prettyPrintRef (ProperRef name) = name

psc/JSON.hs → src/Language/PureScript/Errors/JSON.hsrenamed+7−7

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Main

3+-- Module : Language.PureScript.Errors.JSON

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

6--

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

14

15{-# LANGUAGE TemplateHaskell #-}

16

17−module JSON where

17+module Language.PureScript.Errors.JSON where

18

19import Prelude ()

20import Prelude.Compat

@@ -28,9 +28,9 @@ data ErrorPosition = ErrorPosition

28 , startColumn :: Int

29 , endLine :: Int

30 , endColumn :: Int

31− }

31+ } deriving (Show, Eq, Ord)

32

33−data ErrorSuggestion = ErrorSuggestion { replacement :: String }

33+data ErrorSuggestion = ErrorSuggestion { replacement :: String } deriving (Show, Eq)

34

35data JSONError = JSONError

36 { position :: Maybe ErrorPosition

@@ -40,12 +40,12 @@ data JSONError = JSONError

40 , filename :: Maybe String

41 , moduleName :: Maybe String

42 , suggestion :: Maybe ErrorSuggestion

43− }

43+ } deriving (Show, Eq)

44

45data JSONResult = JSONResult

46 { warnings :: [JSONError]

47 , errors :: [JSONError]

48− }

48+ } deriving (Show, Eq)

49

50$(A.deriveJSON A.defaultOptions ''ErrorPosition)

51$(A.deriveJSON A.defaultOptions ''JSONError)

@@ -64,7 +64,7 @@ toJSONError verbose level e =

64 (P.wikiUri e)

65 (P.spanName <$> sspan)

66 (P.runModuleName <$> P.errorModule e)

67− (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))

67+ (toSuggestion <$> P.errorSuggestion (P.unwrapErrorMessage e))

68 where

69 sspan :: Maybe P.SourceSpan

70 sspan = P.errorSpan e

src/Language/PureScript/Externs.hs+2−1

@@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity

73 -- | The operator symbol

74 , efOperator :: String

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

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

76+ , efAlias :: Maybe (Qualified FixityAlias)

77 } deriving (Show, Read)

78

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

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

159 exportsOp :: DeclarationRef -> Bool

160 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

161 exportsOp (ValueRef ident') = ident' == Op op

162+ exportsOp (TypeOpRef ident') = ident' == Op op

162 exportsOp _ = False

163 exportsOp _ = False

163 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

164 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d

164 fixityDecl _ = Nothing

165 fixityDecl _ = Nothing

src/Language/PureScript/Ide.hs+3−2

@@ -53,11 +53,11 @@ import Language.PureScript.Ide.SourceFile

53import Language.PureScript.Ide.State

54import Language.PureScript.Ide.Types

55import Language.PureScript.Ide.Util

56+import Language.PureScript.Ide.Rebuild

56import System.Directory

57import System.Directory

57import System.FilePath

58import System.FilePath

58import System.Exit

59import System.Exit

59

60

60−

61handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>

62 Command -> m Success

63handleCommand (Load [] []) = loadAllModules

@@ -89,6 +89,8 @@ handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do

89 case rs of

90 Right rs' -> answerRequest outfp rs'

91 Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question)

92+handleCommand (Rebuild file) =

93+ rebuildFile file

92handleCommand Cwd =

94handleCommand Cwd =

93 TextResult . T.pack <$> liftIO getCurrentDirectory

95 TextResult . T.pack <$> liftIO getCurrentDirectory

94handleCommand Quit = liftIO exitSuccess

96handleCommand Quit = liftIO exitSuccess

@@ -238,4 +240,3 @@ filePathFromModule moduleName = do

238 if ex

240 if ex

239 then pure path

241 then pure path

240 else throwError (ModuleFileNotFound moduleName)

242 else throwError (ModuleFileNotFound moduleName)

241−

src/Language/PureScript/Ide/Command.hs+5−1

@@ -63,6 +63,7 @@ data Command

63 -- Import InputFile OutputFile

64 | Import FilePath (Maybe FilePath) [Filter] ImportCommand

65 | List { listType :: ListType }

66+ | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs

66 | Cwd

67 | Cwd

67 | Quit

68 | Quit

68

69

@@ -149,5 +150,8 @@ instance FromJSON Command where

149 filters <- params .:? "filters"

150 filters <- params .:? "filters"

150 importCommand <- params .: "importCommand"

151 importCommand <- params .: "importCommand"

151 pure $ Import fp out (fromMaybe [] filters) importCommand

152 pure $ Import fp out (fromMaybe [] filters) importCommand

153+ "rebuild" -> do

154+ params <- o .: "params"

155+ filePath <- params .: "file"

156+ return $ Rebuild filePath

152 _ -> mzero

157 _ -> mzero

153−

src/Language/PureScript/Ide/Error.hs+12−6

@@ -20,6 +20,7 @@ module Language.PureScript.Ide.Error

20import Data.Aeson

21import Data.Monoid

22import Data.Text (Text, pack)

23+import Language.PureScript.Errors.JSON

23import Language.PureScript.Ide.Types (ModuleIdent)

24import Language.PureScript.Ide.Types (ModuleIdent)

24import qualified Text.Parsec.Error as P

25import qualified Text.Parsec.Error as P

25

26

@@ -31,9 +32,13 @@ data PscIdeError

31 | ModuleNotFound ModuleIdent

32 | ModuleNotFound ModuleIdent

32 | ModuleFileNotFound ModuleIdent

33 | ModuleFileNotFound ModuleIdent

33 | ParseError P.ParseError ErrorMsg

34 | ParseError P.ParseError ErrorMsg

34− deriving (Show, Eq)

35+ | RebuildError [JSONError]

35

36

36instance ToJSON PscIdeError where

37instance ToJSON PscIdeError where

38+ toJSON (RebuildError errs) = object

39+ [ "resultType" .= ("error" :: Text)

40+ , "result" .= errs

41+ ]

37 toJSON err = object

42 toJSON err = object

38 [ "resultType" .= ("error" :: Text)

43 [ "resultType" .= ("error" :: Text)

39 , "result" .= textError err

44 , "result" .= textError err

@@ -44,8 +49,9 @@ textError (GeneralError msg) = pack msg

44textError (NotFound ident) = "Symbol '" <> ident <> "' not found."

49textError (NotFound ident) = "Symbol '" <> ident <> "' not found."

45textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."

50textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."

46textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"

51textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"

47−textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)

52+textError (ParseError parseError msg) = let escape = show

48− where

49− -- escape newlines and other special chars so we can send the error over the socket as a single line

53+ -- escape newlines and other special

50− escape :: P.ParseError -> String

54+ -- chars so we can send the error

51− escape = show

55+ -- over the socket as a single line

56+ in pack $ msg <> ": " <> show (escape parseError)

57+textError (RebuildError err) = pack (show err)

src/Language/PureScript/Ide/Imports.hs+2−2

@@ -76,8 +76,8 @@ compImport (Import n i q) (Import n' i' q')

76 | compImportType i i' /= EQ = compImportType i i'

77 -- This means that for a stable sort, the first implicit import will stay

78 -- the first implicit import

79− | P.isImplicit i && isNothing q = LT

79+ | not (P.isExplicit i) && isNothing q = LT

80− | P.isImplicit i && isNothing q' = GT

80+ | not (P.isExplicit i) && isNothing q' = GT

81 | otherwise = compare n n'

82

83-- | Reads a file and returns the (lines before the imports, the imports, the

src/Language/PureScript/Ide/Rebuild.hsnew file

Binary file not shown.

src/Language/PureScript/Ide/State.hs+4

@@ -51,6 +51,10 @@ getExternFiles = do

51 stateVar <- envStateVar <$> ask

52 liftIO (externsFiles <$> readTVarIO stateVar)

53

54+getExternFile :: (PscIde m) =>

55+ ModuleName -> m (Maybe ExternsFile)

56+getExternFile mn = M.lookup mn <$> getExternFiles

57+

54getAllDecls :: (PscIde m) => m [ExternDecl]

58getAllDecls :: (PscIde m) => m [ExternDecl]

55getAllDecls = concat <$> getPscIdeState

59getAllDecls = concat <$> getPscIdeState

56

60

src/Language/PureScript/Ide/Types.hs+3

@@ -33,6 +33,7 @@ import Data.Maybe (maybeToList)

33import Data.Text (Text (), pack, unpack)

34import qualified Language.PureScript.AST.Declarations as D

35import Language.PureScript.Externs

36+import qualified Language.PureScript.Errors.JSON as P

36import qualified Language.PureScript.Names as N

37import qualified Language.PureScript.Names as N

37import qualified Language.PureScript as P

38import qualified Language.PureScript as P

38

39

@@ -144,6 +145,7 @@ data Success =

144 | PursuitResult [PursuitResponse]

145 | PursuitResult [PursuitResponse]

145 | ImportList [ModuleImport]

146 | ImportList [ModuleImport]

146 | ModuleList [ModuleIdent]

147 | ModuleList [ModuleIdent]

148+ | RebuildSuccess [P.JSONError]

147 deriving(Show, Eq)

149 deriving(Show, Eq)

148

150

149encodeSuccess :: (ToJSON a) => a -> Value

151encodeSuccess :: (ToJSON a) => a -> Value

@@ -157,6 +159,7 @@ instance ToJSON Success where

157 toJSON (PursuitResult resp) = encodeSuccess resp

159 toJSON (PursuitResult resp) = encodeSuccess resp

158 toJSON (ImportList decls) = encodeSuccess decls

160 toJSON (ImportList decls) = encodeSuccess decls

159 toJSON (ModuleList modules) = encodeSuccess modules

161 toJSON (ModuleList modules) = encodeSuccess modules

162+ toJSON (RebuildSuccess modules) = encodeSuccess modules

160

163

161newtype PursuitQuery = PursuitQuery Text

164newtype PursuitQuery = PursuitQuery Text

162 deriving (Show, Eq)

165 deriving (Show, Eq)

src/Language/PureScript/Linter/Imports.hs+9−2

@@ -35,6 +35,7 @@ import qualified Language.PureScript.Constants as C

35data Name

36 = IdentName (Qualified Ident)

37 | TyName (Qualified (ProperName 'TypeName))

38+ | TyOpName (Qualified Ident)

38 | DctorName (Qualified (ProperName 'ConstructorName))

39 | DctorName (Qualified (ProperName 'ConstructorName))

39 | TyClassName (Qualified (ProperName 'ClassName))

40 | TyClassName (Qualified (ProperName 'ClassName))

40 deriving (Eq, Show)

41 deriving (Eq, Show)

@@ -43,6 +44,10 @@ getIdentName :: Maybe ModuleName -> Name -> Maybe Ident

43getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

44getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

44getIdentName _ _ = Nothing

45getIdentName _ _ = Nothing

45

46

47+getTypeOpName :: Maybe ModuleName -> Name -> Maybe Ident

48+getTypeOpName q (TyOpName (Qualified q' name)) | q == q' = Just name

49+getTypeOpName _ _ = Nothing

50+

46getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

51getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

47getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

52getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

48getTypeName _ _ = Nothing

53getTypeName _ _ = Nothing

@@ -190,7 +195,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit =

190 Just q ->

195 Just q ->

191 let usedModuleNames = mapMaybe extractQualName names

196 let usedModuleNames = mapMaybe extractQualName names

192 in unless (q `elem` usedModuleNames) unused

197 in unless (q `elem` usedModuleNames) unused

193− Hiding _ -> checkImplicit HidingImport

198+ Hiding _ -> unless allowImplicit (checkImplicit HidingImport)

194 Explicit [] -> unused

199 Explicit [] -> unused

195 Explicit declrefs -> checkExplicit declrefs

200 Explicit declrefs -> checkExplicit declrefs

196

201

@@ -265,6 +270,7 @@ findUsedRefs env mni qualifierName names =

265 let

270 let

266 classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

271 classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

267 valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

272 valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

273+ typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names

268 types = mapMaybe (getTypeName qualifierName) names

274 types = mapMaybe (getTypeName qualifierName) names

269 dctors = mapMaybe (matchDctor qualifierName) names

275 dctors = mapMaybe (matchDctor qualifierName) names

270 typesWithDctors = reconstructTypeRefs dctors

276 typesWithDctors = reconstructTypeRefs dctors

@@ -272,7 +278,7 @@ findUsedRefs env mni qualifierName names =

272 typesRefs

278 typesRefs

273 = map (flip TypeRef (Just [])) typesWithoutDctors

279 = map (flip TypeRef (Just [])) typesWithoutDctors

274 ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

280 ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

275− in classRefs ++ typesRefs ++ valueRefs

281+ in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs

276

282

277 where

283 where

278

284

@@ -309,6 +315,7 @@ matchName _ _ _ = Nothing

309extractQualName :: Name -> Maybe ModuleName

315extractQualName :: Name -> Maybe ModuleName

310extractQualName (IdentName (Qualified q _)) = q

316extractQualName (IdentName (Qualified q _)) = q

311extractQualName (TyName (Qualified q _)) = q

317extractQualName (TyName (Qualified q _)) = q

318+extractQualName (TyOpName (Qualified q _)) = q

312extractQualName (TyClassName (Qualified q _)) = q

319extractQualName (TyClassName (Qualified q _)) = q

313extractQualName (DctorName (Qualified q _)) = q

320extractQualName (DctorName (Qualified q _)) = q

314

321

src/Language/PureScript/Make.hs+45−22

@@ -14,6 +14,7 @@ module Language.PureScript.Make

14 , ProgressMessage(..), renderProgressMessage

15 , MakeActions(..)

16 , Externs()

17+ , rebuildModule

17 , make

18 , make

18

19

19 -- * Implementation of Make API using files on disk

20 -- * Implementation of Make API using files on disk

@@ -42,6 +43,7 @@ import Control.Concurrent.Lifted as C

42

43

43import Data.List (foldl', sort)

44import Data.List (foldl', sort)

44import Data.Maybe (fromMaybe, catMaybes, isJust)

45import Data.Maybe (fromMaybe, catMaybes, isJust)

46+import Data.Either (partitionEithers)

45import Data.Time.Clock

47import Data.Time.Clock

46import Data.String (fromString)

48import Data.String (fromString)

47import Data.Foldable (for_)

49import Data.Foldable (for_)

@@ -146,6 +148,28 @@ data RebuildPolicy

146 -- | Always rebuild this module

148 -- | Always rebuild this module

147 | RebuildAlways deriving (Show, Read, Eq, Ord)

149 | RebuildAlways deriving (Show, Read, Eq, Ord)

148

150

151+-- | Rebuild a single module

152+rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

153+ => MakeActions m

154+ -> [ExternsFile]

155+ -> Module

156+ -> m ExternsFile

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

158+ progress $ CompilingModule moduleName

159+ let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

160+ lint m

161+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do

162+ [desugared] <- desugar externs [m]

163+ runCheck' env $ typeCheckModule desugared

164+ checkExhaustiveModule env' checked

165+ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

166+ let mod' = Module ss coms moduleName regrouped exps

167+ corefn = CF.moduleToCoreFn env' mod'

168+ [renamed] = renameInModules [corefn]

169+ exts = moduleToExternsFile mod' env'

170+ evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts

171+ return exts

172+

149-- |

173-- |

150-- Compiles in "make" mode, compiling each module separately to a js files and an externs file

174-- Compiles in "make" mode, compiling each module separately to a js files and an externs file

151--

175--

@@ -156,7 +180,7 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE

156 => MakeActions m

180 => MakeActions m

157 -> [Module]

181 -> [Module]

158 -> m Environment

182 -> m Environment

159−make MakeActions{..} ms = do

183+make ma@MakeActions{..} ms = do

160 requirePath <- asks optionsRequirePath

184 requirePath <- asks optionsRequirePath

161 when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath

185 when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath

162

186

@@ -220,21 +244,7 @@ make MakeActions{..} ms = do

220 _ -> True

244 _ -> True

221

245

222 let rebuild = do

246 let rebuild = do

223− (exts, warnings) <- listen $ do

247+ (exts, warnings) <- listen $ rebuildModule ma externs m

224− progress $ CompilingModule moduleName

225− let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

226− lint m

227− ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do

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

229− runCheck' env $ typeCheckModule desugared

230− checkExhaustiveModule env' checked

231− regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

232− let mod' = Module ss coms moduleName regrouped exps

233− corefn = CF.moduleToCoreFn env' mod'

234− [renamed] = renameInModules [corefn]

235− exts = moduleToExternsFile mod' env'

236− evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts

237− return exts

238 markComplete (Just (warnings, exts)) Nothing

248 markComplete (Just (warnings, exts)) Nothing

239

249

240 if shouldRebuild

250 if shouldRebuild

@@ -417,11 +427,10 @@ checkForeignDecls m path = do

417 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path

427 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path

418

428

419 foreignIdentsStrs <- either errorParsingModule pure $ getExps js

429 foreignIdentsStrs <- either errorParsingModule pure $ getExps js

420− let foreignIdents =

430+ foreignIdents <- either

421− either

431+ errorInvalidForeignIdentifiers

422− (internalError . ("checkForeignDecls: unexpected idents: " ++) . show)

423− S.fromList

432+ (pure . S.fromList)

424− (traverse parseIdent foreignIdentsStrs)

433+ (parseIdents foreignIdentsStrs)

425 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)

434 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)

426

435

427 let unusedFFI = foreignIdents S.\\ importedIdents

436 let unusedFFI = foreignIdents S.\\ importedIdents

@@ -443,10 +452,24 @@ checkForeignDecls m path = do

443 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

452 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

444 getExps = Bundle.getExportedIdentifiers (runModuleName mname)

453 getExps = Bundle.getExportedIdentifiers (runModuleName mname)

445

454

455+ errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a

456+ errorInvalidForeignIdentifiers =

457+ throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)

458+

459+ parseIdents :: [String] -> Either [String] [Ident]

460+ parseIdents strs =

461+ case partitionEithers (map parseIdent strs) of

462+ ([], idents) ->

463+ Right idents

464+ (errs, _) ->

465+ Left errs

466+

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

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

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

469+ -- identifier should be enough.

447 parseIdent :: String -> Either String Ident

470 parseIdent :: String -> Either String Ident

448 parseIdent str = try str <|> try ("(" ++ str ++ ")")

471 parseIdent str = try str <|> try ("(" ++ str ++ ")")

449 where

472 where

450− try s = either (Left . show) Right $ do

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

451 ts <- PSParser.lex "" s

474 ts <- PSParser.lex "" s

452 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts

475 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts

src/Language/PureScript/ModuleDependencies.hs+37−25

@@ -1,19 +1,8 @@

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

2−--

3−-- Module : Language.PureScript.ModuleDependencies

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Provides the ability to sort modules based on module dependencies

12−--

13−-----------------------------------------------------------------------------

14−

15{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

16

2

3+-- |

4+-- Provides the ability to sort modules based on module dependencies

5+--

17module Language.PureScript.ModuleDependencies (

6module Language.PureScript.ModuleDependencies (

18 sortModules,

7 sortModules,

19 ModuleGraph

8 ModuleGraph

@@ -40,7 +29,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

40--

29--

41sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)

30sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)

42sortModules ms = do

31sortModules ms = do

43− let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

32+ let verts = map goModule ms

44 ms' <- mapM toModule $ stronglyConnComp verts

33 ms' <- mapM toModule $ stronglyConnComp verts

45 let (graph, fromVertex, toVertex) = graphFromEdges verts

34 let (graph, fromVertex, toVertex) = graphFromEdges verts

46 moduleGraph = do (_, mn, _) <- verts

35 moduleGraph = do (_, mn, _) <- verts

@@ -49,30 +38,53 @@ sortModules ms = do

49 toKey i = case fromVertex i of (_, key, _) -> key

38 toKey i = case fromVertex i of (_, key, _) -> key

50 return (mn, filter (/= mn) (map toKey deps))

39 return (mn, filter (/= mn) (map toKey deps))

51 return (ms', moduleGraph)

40 return (ms', moduleGraph)

41+ where

42+ goModule :: Module -> (Module, ModuleName, [ModuleName])

43+ goModule m@(Module _ _ _ ds _) =

44+ let ams = concatMap extractQualAs ds

45+ in (m, getModuleName m, nub (concatMap (usedModules ams) ds))

46+

47+ -- Extract module names that have been brought into scope by an `as` import.

48+ extractQualAs :: Declaration -> [ModuleName]

49+ extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d

50+ extractQualAs (ImportDeclaration _ _ (Just am) _) = [am]

51+ extractQualAs _ = []

52

53-- |

54−-- Calculate a list of used modules based on explicit imports and qualified names

54+-- Calculate a list of used modules based on explicit imports and qualified

55+-- names. `ams` is a list of `ModuleNames` that refer to names brought into

56+-- scope by importing with `as` - this ensures that when building the list we

57+-- don't inadvertantly assume a dependency on an actual module, if there is a

58+-- module that has the same name as the qualified import.

55--

59--

56−usedModules :: Declaration -> [ModuleName]

60+usedModules :: [ModuleName] -> Declaration -> [ModuleName]

57−usedModules d =

61+usedModules ams d =

58 let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])

62 let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])

59 (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)

63 (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)

60 in nub (f d ++ g d)

64 in nub (f d ++ g d)

61 where

65 where

66+

62 forDecls :: Declaration -> [ModuleName]

67 forDecls :: Declaration -> [ModuleName]

63− forDecls (ImportDeclaration mn _ _ _) = [mn]

68+ forDecls (ImportDeclaration mn _ _ _) =

64− forDecls (FixityDeclaration _ _ (Just (Left (Qualified (Just mn) _)))) = [mn]

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]

65− forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn]

72+ forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _)))

73+ | mn `notElem` ams = [mn]

66− forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

74+ forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)

75+ | mn `notElem` ams = [mn]

67 forDecls _ = []

76 forDecls _ = []

68

77

69 forValues :: Expr -> [ModuleName]

78 forValues :: Expr -> [ModuleName]

70− forValues (Var (Qualified (Just mn) _)) = [mn]

79+ forValues (Var (Qualified (Just mn) _))

80+ | mn `notElem` ams = [mn]

71− forValues (Constructor (Qualified (Just mn) _)) = [mn]

81+ forValues (Constructor (Qualified (Just mn) _))

82+ | mn `notElem` ams = [mn]

72 forValues _ = []

83 forValues _ = []

73

84

74 forTypes :: Type -> [ModuleName]

85 forTypes :: Type -> [ModuleName]

75− forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

86+ forTypes (TypeConstructor (Qualified (Just mn) _))

87+ | mn `notElem` ams = [mn]

76 forTypes _ = []

88 forTypes _ = []

77

89

78-- |

90-- |

src/Language/PureScript/Parser/Declarations.hs+6−4

@@ -122,12 +122,13 @@ parseFixityDeclaration :: TokenParser Declaration

122parseFixityDeclaration = do

123 fixity <- parseFixity

124 indented

125− alias <- P.optionMaybe $ aliased <* reserved "as"

125+ alias <- P.optionMaybe $ parseQualified aliased <* reserved "as"

126 name <- symbol

127 return $ FixityDeclaration fixity name alias

128 where

129− aliased = (Left <$> parseQualified (Ident <$> identifier))

129+ aliased = (AliasValue . Ident <$> identifier)

130− <|> (Right <$> parseQualified (ProperName <$> uname))

130+ <|> (AliasConstructor <$> properName)

131+ <|> reserved "type" *> (AliasType <$> properName)

131

132

132parseImportDeclaration :: TokenParser Declaration

133parseImportDeclaration :: TokenParser Declaration

133parseImportDeclaration = do

134parseImportDeclaration = do

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

164 <|> parseProperRef

165 <|> parseProperRef

165 <|> (TypeClassRef <$> (reserved "class" *> properName))

166 <|> (TypeClassRef <$> (reserved "class" *> properName))

166 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

167 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

168+ <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol)))

167 where

169 where

168 parseProperRef = do

170 parseProperRef = do

169 name <- properName

171 name <- properName

@@ -483,7 +485,7 @@ parseConstructorBinder :: TokenParser Binder

483parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

485parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

484

486

485parseObjectBinder:: TokenParser Binder

487parseObjectBinder:: TokenParser Binder

486−parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

488+parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

487

489

488parseArrayBinder :: TokenParser Binder

490parseArrayBinder :: TokenParser Binder

489parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)

491parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)

src/Language/PureScript/Parser/Types.hs+6−2

@@ -8,6 +8,7 @@ module Language.PureScript.Parser.Types (

8import Control.Applicative

9import Control.Monad (when, unless)

10

11+import Language.PureScript.Names

11import Language.PureScript.Types

12import Language.PureScript.Types

12import Language.PureScript.Parser.Common

13import Language.PureScript.Parser.Common

13import Language.PureScript.Parser.Kinds

14import Language.PureScript.Parser.Kinds

@@ -53,7 +54,7 @@ parseTypeAtom = indented *> P.choice

53 , parseTypeConstructor

54 , parseTypeConstructor

54 -- This try is needed due to some unfortunate ambiguities between rows and kinded types

55 -- This try is needed due to some unfortunate ambiguities between rows and kinded types

55 , P.try (parens parseRow)

56 , P.try (parens parseRow)

56− , parens parsePolyType

57+ , ParensInType <$> parens parsePolyType

57 ]

58 ]

58

59

59parseConstrainedType :: TokenParser Type

60parseConstrainedType :: TokenParser Type

@@ -74,7 +75,10 @@ parseConstrainedType = do

74parseAnyType :: TokenParser Type

75parseAnyType :: TokenParser Type

75parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

76parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

76 where

77 where

78+ operators = [ [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident ->

79+ return (BinaryNoParensType (TypeOp ident))) P.AssocRight

80+ ]

77− operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

81+ , [ P.Infix (return TypeApp) P.AssocLeft ]

78 , [ P.Infix (rarrow >> return function) P.AssocRight ]

82 , [ P.Infix (rarrow >> return function) P.AssocRight ]

79 ]

83 ]

80 postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

84 postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

src/Language/PureScript/Sugar/Names.hs+56−5

@@ -85,6 +85,12 @@ desugarImportsWithEnv externs modules = do

85 forTyCon _ = Nothing

86 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

87 toExportedType _ = Nothing

88+ exportedTypeOps :: [(Ident, ModuleName)]

89+ exportedTypeOps = mapMaybe toExportedTypeOp efExports

90+ where

91+ toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName)

92+ toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r

93+ toExportedTypeOp _ = Nothing

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

94 exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

89 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

95 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

90 where

96 where

@@ -126,6 +132,7 @@ elaborateExports :: Exports -> Module -> Module

126elaborateExports exps (Module ss coms mn decls refs) =

132elaborateExports exps (Module ss coms mn decls refs) =

127 Module ss coms mn decls $

133 Module ss coms mn decls $

128 Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++

134 Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++

135+ map TypeOpRef (my exportedTypeOps) ++

129 map TypeClassRef (my exportedTypeClasses) ++

136 map TypeClassRef (my exportedTypeClasses) ++

130 map ValueRef (my exportedValues) ++

137 map ValueRef (my exportedValues) ++

131 maybe [] (filter isModuleRef) refs

138 maybe [] (filter isModuleRef) refs

@@ -171,7 +178,15 @@ renameInModule env imports (Module ss coms mn decls exps) =

171 updateDecl (pos, bound) (ExternDeclaration name ty) =

178 updateDecl (pos, bound) (ExternDeclaration name ty) =

172 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

179 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

173 updateDecl (pos, bound) (FixityDeclaration fx name alias) =

180 updateDecl (pos, bound) (FixityDeclaration fx name alias) =

174− (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias)

181+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias)

182+ where

183+ updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias)

184+ updateAlias (Qualified mn' (AliasValue ident)) =

185+ fmap AliasValue <$> updateValueName (Qualified mn' ident) pos

186+ updateAlias (Qualified mn' (AliasConstructor ctor)) =

187+ fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos

188+ updateAlias (Qualified mn' (AliasType ty)) =

189+ fmap AliasType <$> updateTypeName (Qualified mn' ty) pos

175 updateDecl s d = return (s, d)

190 updateDecl s d = return (s, d)

176

191

177 updateValue

192 updateValue

@@ -231,6 +246,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

231 updateTypesEverywhere pos = everywhereOnTypesM updateType

246 updateTypesEverywhere pos = everywhereOnTypesM updateType

232 where

247 where

233 updateType :: Type -> m Type

248 updateType :: Type -> m Type

249+ updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos

234 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

250 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

235 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

251 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

236 updateType t = return t

252 updateType t = return t

@@ -242,22 +258,57 @@ renameInModule env imports (Module ss coms mn decls exps) =

242 :: Qualified (ProperName 'TypeName)

258 :: Qualified (ProperName 'TypeName)

243 -> Maybe SourceSpan

259 -> Maybe SourceSpan

244 -> m (Qualified (ProperName 'TypeName))

260 -> m (Qualified (ProperName 'TypeName))

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

261+ updateTypeName =

262+ update UnknownType

263+ (importedTypes imports)

264+ (resolveType . exportedTypes)

265+ TyName

266+ (("type " ++) . runProperName)

267+

268+ updateTypeOpName

269+ :: Qualified Ident

270+ -> Maybe SourceSpan

271+ -> m (Qualified Ident)

272+ updateTypeOpName =

273+ update

274+ UnknownTypeOp

275+ (importedTypeOps imports)

276+ (resolve . exportedTypeOps)

277+ TyOpName

278+ (("type operator" ++) . runIdent)

246

279

247 updateDataConstructorName

280 updateDataConstructorName

248 :: Qualified (ProperName 'ConstructorName)

281 :: Qualified (ProperName 'ConstructorName)

249 -> Maybe SourceSpan

282 -> Maybe SourceSpan

250 -> m (Qualified (ProperName 'ConstructorName))

283 -> m (Qualified (ProperName 'ConstructorName))

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

284+ updateDataConstructorName =

285+ update

286+ (flip UnknownDataConstructor Nothing)

287+ (importedDataConstructors imports)

288+ (resolveDctor . exportedTypes)

289+ DctorName

290+ (("data constructor " ++) . runProperName)

252

291

253 updateClassName

292 updateClassName

254 :: Qualified (ProperName 'ClassName)

293 :: Qualified (ProperName 'ClassName)

255 -> Maybe SourceSpan

294 -> Maybe SourceSpan

256 -> m (Qualified (ProperName 'ClassName))

295 -> m (Qualified (ProperName 'ClassName))

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

296+ updateClassName =

297+ update

298+ UnknownTypeClass

299+ (importedTypeClasses imports)

300+ (resolve . exportedTypeClasses)

301+ TyClassName

302+ (("class " ++) . runProperName)

258

303

259 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

304 updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

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

305+ updateValueName =

306+ update

307+ UnknownValue

308+ (importedValues imports)

309+ (resolve . exportedValues)

310+ IdentName

311+ (("value " ++) . runIdent)

261

312

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

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

263 -- module of original definition.

314 -- module of original definition.

src/Language/PureScript/Sugar/Names/Env.hs+22−3

@@ -14,6 +14,7 @@ module Language.PureScript.Sugar.Names.Env

14 , envModuleImports

15 , envModuleExports

16 , exportType

17+ , exportTypeOp

17 , exportTypeClass

18 , exportTypeClass

18 , exportValue

19 , exportValue

19 , getExports

20 , getExports

@@ -70,6 +71,10 @@ data Imports = Imports

70 --

71 --

71 importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]

72 importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]

72 -- |

73 -- |

74+ -- Local names for type operators within a module mapped to to their qualified names

75+ --

76+ , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident]

77+ -- |

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

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

74 --

79 --

75 , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]

80 , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]

@@ -96,7 +101,7 @@ data Imports = Imports

96-- An empty 'Imports' value.

101-- An empty 'Imports' value.

97--

102--

98nullImports :: Imports

103nullImports :: Imports

99−nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty

104+nullImports = Imports M.empty M.empty M.empty M.empty M.empty S.empty S.empty

100

105

101-- |

106-- |

102-- The exported declarations from a module.

107-- The exported declarations from a module.

@@ -109,6 +114,11 @@ data Exports = Exports

109 --

114 --

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

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

111 -- |

116 -- |

117+ -- The type operators exported from each module along with the module they

118+ -- originally came from.

119+ --

120+ , exportedTypeOps :: [(Ident, ModuleName)]

121+ -- |

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

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

113 -- came from.

123 -- came from.

114 --

124 --

@@ -124,7 +134,7 @@ data Exports = Exports

124-- An empty 'Exports' value.

134-- An empty 'Exports' value.

125--

135--

126nullExports :: Exports

136nullExports :: Exports

127−nullExports = Exports [] [] []

137+nullExports = Exports [] [] [] []

128

138

129-- |

139-- |

130-- The imports and exports for a collection of modules. The 'SourceSpan' is used

140-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -155,7 +165,7 @@ envModuleExports (_, _, exps) = exps

155-- The exported types from the @Prim@ module

165-- The exported types from the @Prim@ module

156--

166--

157primExports :: Exports

167primExports :: Exports

158−primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []

168+primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) []

159 where

169 where

160 mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

170 mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)

161 mkClassEntry (Qualified mn name) = (name, fromJust mn)

171 mkClassEntry (Qualified mn name) = (name, fromJust mn)

@@ -183,6 +193,15 @@ exportType exps name dctors mn = do

183 when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

193 when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

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

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

185

195

196+-- |

197+-- Safely adds a type operator to some exports, returning an error if a

198+-- conflict occurs.

199+--

200+exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

201+exportTypeOp exps name mn = do

202+ typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps)

203+ return $ exps { exportedTypeOps = typeOps }

204+

186-- |

205-- |

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

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

188--

207--

src/Language/PureScript/Sugar/Names/Exports.hs+38−6

@@ -47,6 +47,7 @@ findExportable (Module _ _ mn ds _) =

47 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

48 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

49 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

50+ updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn

50 updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

51 updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

51 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

52 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

52 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

53 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

@@ -70,6 +71,7 @@ resolveExports env mn imps exps refs =

70 warnDupeRefs :: [DeclarationRef] -> m ()

71 warnDupeRefs :: [DeclarationRef] -> m ()

71 warnDupeRefs = traverse_ $ \case

72 warnDupeRefs = traverse_ $ \case

72 TypeRef name _ -> warnDupe $ "type " ++ runProperName name

73 TypeRef name _ -> warnDupe $ "type " ++ runProperName name

74+ TypeOpRef name -> warnDupe $ "type operator " ++ runIdent name

73 ValueRef name -> warnDupe $ "value " ++ runIdent name

75 ValueRef name -> warnDupe $ "value " ++ runIdent name

74 TypeClassRef name -> warnDupe $ "class " ++ runProperName name

76 TypeClassRef name -> warnDupe $ "class " ++ runProperName name

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

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

@@ -89,22 +91,28 @@ resolveExports env mn imps exps refs =

89 rethrowWithPosition pos $ elaborateModuleExports result r

91 rethrowWithPosition pos $ elaborateModuleExports result r

90 elaborateModuleExports result (ModuleRef name) | name == mn = do

92 elaborateModuleExports result (ModuleRef name) | name == mn = do

91 let types' = exportedTypes result ++ exportedTypes exps

93 let types' = exportedTypes result ++ exportedTypes exps

94+ let typeOps' = exportedTypeOps result ++ exportedTypeOps exps

92 let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

95 let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

93 let values' = exportedValues result ++ exportedValues exps

96 let values' = exportedValues result ++ exportedValues exps

97+ return result

94− return result { exportedTypes = types'

98+ { exportedTypes = types'

99+ , exportedTypeOps = typeOps'

95− , exportedTypeClasses = classes'

100+ , exportedTypeClasses = classes'

96− , exportedValues = values' }

101+ , exportedValues = values'

102+ }

97 elaborateModuleExports result (ModuleRef name) = do

103 elaborateModuleExports result (ModuleRef name) = do

98 let isPseudo = isPseudoModule name

104 let isPseudo = isPseudoModule name

99 when (not isPseudo && not (isImportedModule name)) $

105 when (not isPseudo && not (isImportedModule name)) $

100 throwError . errorMessage . UnknownExportModule $ name

106 throwError . errorMessage . UnknownExportModule $ name

101 reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

107 reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)

108+ reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps)

102 reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

109 reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)

103 reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

110 reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)

104 reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

111 reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)

105 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

112 result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

113+ result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps)

106− result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

114+ result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses)

107− foldM (uncurry . exportValue) result'' (map resolveValue reValues)

115+ foldM (uncurry . exportValue) result''' (map resolveValue reValues)

108 elaborateModuleExports result _ = return result

116 elaborateModuleExports result _ = return result

109

117

110 -- Extracts a list of values for a module based on a lookup table. If the

118 -- Extracts a list of values for a module based on a lookup table. If the

@@ -163,6 +171,11 @@ resolveExports env mn imps exps refs =

163 return ((name, relevantDctors `intersect` dctors'), mnOrig)

171 return ((name, relevantDctors `intersect` dctors'), mnOrig)

164 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

172 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

165

173

174+ -- Looks up an imported type operator and re-qualifies it with the original

175+ -- module it came from.

176+ resolveTypeOp :: Qualified Ident -> (Ident, ModuleName)

177+ resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

178+ resolve exportedTypeOps ident

166

179

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

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

168 -- came from.

181 -- came from.

@@ -202,9 +215,15 @@ filterModule

202 -> m Exports

215 -> m Exports

203filterModule mn exps refs = do

216filterModule mn exps refs = do

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

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

218+ typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs

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

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

206 classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs

220 classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs

221+ return $ exps

222+ { exportedTypes = types

223+ , exportedTypeOps = typeOps

207− return exps { exportedTypes = types , exportedTypeClasses = classes , exportedValues = values }

224+ , exportedTypeClasses = classes

225+ , exportedValues = values

226+ }

208

227

209 where

228 where

210

229

@@ -241,6 +260,19 @@ filterModule mn exps refs = do

241 unless (name `elem` exps') $

260 unless (name `elem` exps') $

242 throwError . errorMessage $ UnknownExportDataConstructor tcon name

261 throwError . errorMessage $ UnknownExportDataConstructor tcon name

243

262

263+ -- Takes a list of all the exportable type operators, the accumulated list of

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

265+ -- ref refers to a value in the list of exportable values, the value is

266+ -- included in the result.

267+ filterTypeOps :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]

268+ filterTypeOps exps' result (PositionedDeclarationRef pos _ r) =

269+ rethrowWithPosition pos $ filterTypeOps exps' result r

270+ filterTypeOps exps' result (TypeOpRef name) =

271+ if (name, mn) `elem` exps'

272+ then return $ (name, mn) : result

273+ else throwError . errorMessage . UnknownExportTypeOp $ name

274+ filterTypeOps _ result _ = return result

275+

244 -- Takes a list of all the exportable classes, the accumulated list of

276 -- Takes a list of all the exportable classes, the accumulated list of

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

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

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

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

src/Language/PureScript/Sugar/Names/Imports.hs+11−2

@@ -97,6 +97,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

97 let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports

98 scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'

99 resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

100+

100 return (Module ss coms currentModule decls' exps, resolved)

101 return (Module ss coms currentModule decls' exps, resolved)

101

102

102 where

103 where

@@ -118,6 +119,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

118 warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()

119 warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()

119 warnDupeRefs pos = traverse_ $ \case

120 warnDupeRefs pos = traverse_ $ \case

120 TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name

121 TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name

122+ TypeOpRef name -> warnDupe pos $ "type operator " ++ runIdent name

121 ValueRef name -> warnDupe pos $ "value " ++ runIdent name

123 ValueRef name -> warnDupe pos $ "value " ++ runIdent name

122 TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name

124 TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name

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

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

@@ -203,6 +205,7 @@ resolveImport importModule exps imps impQual = resolveByType

203 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

205 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

204 let isEmptyImport

206 let isEmptyImport

205 = M.null (importedTypes imps')

207 = M.null (importedTypes imps')

208+ && M.null (importedTypeOps imps')

206 && M.null (importedDataConstructors imps')

209 && M.null (importedDataConstructors imps')

207 && M.null (importedTypeClasses imps')

210 && M.null (importedTypeClasses imps')

208 && M.null (importedValues imps')

211 && M.null (importedValues imps')

@@ -221,6 +224,8 @@ resolveImport importModule exps imps impQual = resolveByType

221 checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name

224 checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name

222 let allDctors = fst `map` allExportedDataConstructors name

225 let allDctors = fst `map` allExportedDataConstructors name

223 maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors

226 maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors

227+ check (TypeOpRef name) =

228+ checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name

224 check (TypeClassRef name) =

229 check (TypeClassRef name) =

225 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

230 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

226 check (ModuleRef name) | isHiding =

231 check (ModuleRef name) | isHiding =

@@ -267,8 +272,9 @@ resolveImport importModule exps imps impQual = resolveByType

267 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

272 importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

268 importAll importer = do

273 importAll importer = do

269 imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

274 imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

275+ imp'' <- foldM (\m (name, _) -> importer m (TypeOpRef name)) imp' (exportedTypeOps exps)

270− imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)

276+ imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps)

271− foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

277+ foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps)

272

278

273 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

279 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

274 importRef prov imp (PositionedDeclarationRef pos _ r) =

280 importRef prov imp (PositionedDeclarationRef pos _ r) =

@@ -286,6 +292,9 @@ resolveImport importModule exps imps impQual = resolveByType

286 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

292 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

287 let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

293 let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

288 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

294 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

295+ importRef prov imp (TypeOpRef name) = do

296+ let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov

297+ return $ imp { importedTypeOps = ops' }

289 importRef prov imp (TypeClassRef name) = do

298 importRef prov imp (TypeClassRef name) = do

290 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

299 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

291 return $ imp { importedTypeClasses = typeClasses' }

300 return $ imp { importedTypeClasses = typeClasses' }

src/Language/PureScript/Sugar/ObjectWildcards.hs+24−7

@@ -9,6 +9,7 @@ module Language.PureScript.Sugar.ObjectWildcards (

9import Prelude ()

10import Prelude.Compat

11

12+import Control.Monad (forM)

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

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

13import Control.Monad.Supply.Class

14import Control.Monad.Supply.Class

14

15

@@ -45,11 +46,21 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

45 desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

46 desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

46 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

47 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

47 obj <- freshIdent'

48 obj <- freshIdent'

48− Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

49+ Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps

49 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

50 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

50 desugarExpr (Accessor prop u) | isAnonymousArgument u = do

51 desugarExpr (Accessor prop u) | isAnonymousArgument u = do

51 arg <- freshIdent'

52 arg <- freshIdent'

52− return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

53+ return $ Abs (Left arg) (Accessor prop (argToExpr arg))

54+ desugarExpr (Case args cas) | any isAnonymousArgument args = do

55+ argIdents <- forM args freshIfAnon

56+ let args' = zipWith (\p -> maybe p argToExpr) args argIdents

57+ return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)

58+ desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do

59+ u' <- freshIfAnon u

60+ t' <- freshIfAnon t

61+ f' <- freshIfAnon f

62+ let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f')

63+ return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

53 desugarExpr e = return e

64 desugarExpr e = return e

54

65

55 wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

66 wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

@@ -71,8 +82,14 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

71 isAnonymousArgument _ = False

82 isAnonymousArgument _ = False

72

83

73 mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

84 mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

74− mkProp (name, e)

85+ mkProp (name, e) = do

75− | isAnonymousArgument e = do

86+ arg <- freshIfAnon e

87+ return (arg, (name, maybe e argToExpr arg))

88+

89+ freshIfAnon :: Expr -> m (Maybe Ident)

90+ freshIfAnon u

76− arg <- freshIdent'

91+ | isAnonymousArgument u = Just <$> freshIdent'

92+ | otherwise = return Nothing

93+

94+ argToExpr :: Ident -> Expr

77− return (Just arg, (name, Var (Qualified Nothing arg)))

95+ argToExpr = Var . Qualified Nothing

78− | otherwise = return (Nothing, (name, e))

src/Language/PureScript/Sugar/Operators.hs+175−42

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

1−{-# LANGUAGE Rank2Types #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

@@ -11,11 +10,11 @@

11-- The value parser ignores fixity data when parsing binary operator applications, so

10-- The value parser ignores fixity data when parsing binary operator applications, so

12-- it is necessary to reorder them here.

11-- it is necessary to reorder them here.

13--

12--

14−module Language.PureScript.Sugar.Operators (

13+module Language.PureScript.Sugar.Operators

15− rebracket,

14+ ( rebracket

16− removeSignedLiterals,

15+ , removeSignedLiterals

17− desugarOperatorSections

16+ , desugarOperatorSections

18−) where

17+ ) where

19

18

20import Prelude ()

19import Prelude ()

21import Prelude.Compat

20import Prelude.Compat

@@ -27,30 +26,29 @@ import Language.PureScript.Externs

27import Language.PureScript.Names

26import Language.PureScript.Names

28import Language.PureScript.Sugar.Operators.Binders

27import Language.PureScript.Sugar.Operators.Binders

29import Language.PureScript.Sugar.Operators.Expr

28import Language.PureScript.Sugar.Operators.Expr

30−import Language.PureScript.Traversals (defS)

29+import Language.PureScript.Sugar.Operators.Types

30+import Language.PureScript.Traversals (defS, sndM)

31+import Language.PureScript.Types

31

32

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

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

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

33import Control.Monad.Supply.Class

35import Control.Monad.Supply.Class

34

36

35import Data.Function (on)

37import Data.Function (on)

38+import Data.Functor.Identity

36−import Data.List (groupBy, sortBy)

39+import Data.List (partition, groupBy, sortBy)

37import Data.Maybe (mapMaybe)

40import Data.Maybe (mapMaybe)

38import qualified Data.Map as M

41import qualified Data.Map as M

39

42

40import qualified Language.PureScript.Constants as C

43import qualified Language.PureScript.Constants as C

41

44

42−-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional

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

43

46

44-- |

47-- |

45-- An operator associated with its declaration position, fixity, and the name

48-- An operator associated with its declaration position, fixity, and the name

46-- of the function or data constructor it is an alias for.

49-- of the function or data constructor it is an alias for.

47--

50--

48−type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName)

51+type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias))

49−

50−-- |

51−-- An operator can be an alias for a function or a data constructor.

52−--

53−type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))

54

52

55-- |

53-- |

56-- Remove explicit parentheses and reorder binary operator applications

54-- Remove explicit parentheses and reorder binary operator applications

@@ -62,23 +60,57 @@ rebracket

62 -> [Module]

60 -> [Module]

63 -> m [Module]

61 -> m [Module]

64rebracket externs ms = do

62rebracket externs ms = do

63+ let (typeFixities, valueFixities) = partition isTypeFixity $

65− let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

64+ concatMap externsFixities externs ++ concatMap collectFixities ms

65+

66− ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities

66+ ensureNoDuplicates' $ valueFixities

67+ ensureNoDuplicates' $ typeFixities

68+

67− let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities

69+ let valueOpTable = customOperatorTable' valueFixities

70+ typeOpTable = customOperatorTable' typeFixities

68− ms' <- traverse (rebracketModule opTable) ms

71+ ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms

72+

73+ let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities)

69− let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

74+ typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities)

70− mapM (renameAliasedOperators aliased) ms'

75+ mapM (renameAliasedOperators valueAliased typeAliased) ms'

71

76

72 where

77 where

73

78

79+ isTypeFixity :: FixityRecord -> Bool

80+ -- Nothing case for FixityAlias can only ever be a value fixity, as it's not

81+ -- possible to define types with operator names aside through aliasing.

82+ -- TODO: This comment is redundant after 0.9.

83+ isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True

84+ isTypeFixity _ = False

85+

86+ ensureNoDuplicates' :: [FixityRecord] -> m ()

87+ ensureNoDuplicates' =

88+ ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos))

89+

90+ customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]]

91+ customOperatorTable' =

92+ customOperatorTable . map (\(i, _, f, _) -> (i, f))

93+

74− makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)

94+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias)

75 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

95 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

76

96

77− renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module

97+ renameAliasedOperators

98+ :: M.Map (Qualified Ident) (Qualified FixityAlias)

99+ -> M.Map (Qualified Ident) (Qualified FixityAlias)

100+ -> Module

101+ -> m Module

78− renameAliasedOperators aliased (Module ss coms mn ds exts) =

102+ renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =

79 Module ss coms mn <$> mapM f' ds <*> pure exts

103 Module ss coms mn <$> mapM f' ds <*> pure exts

80 where

104 where

105+ (goDecl', goExpr') = updateTypes goType

106+ (f', _, _, _, _) =

81− (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS

107+ everywhereWithContextOnValuesM

108+ Nothing

109+ (\pos -> uncurry goDecl <=< goDecl' pos)

110+ (\pos -> uncurry goExpr <=< goExpr' pos)

111+ goBinder

112+ defS

113+ defS

82

114

83 goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)

115 goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)

84 goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)

116 goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)

@@ -86,27 +118,39 @@ rebracket externs ms = do

86

118

87 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

119 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

88 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

120 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

89− goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of

121+ goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of

90− Just (Left alias) -> Var alias

122+ Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias)

91− Just (Right alias) -> Constructor alias

123+ Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias)

92− Nothing -> Var name)

124+ _ -> Var name)

93 goExpr pos other = return (pos, other)

125 goExpr pos other = return (pos, other)

94

126

95 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

127 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

96 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

128 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

97− goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of

129+ goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of

98− Just (Left alias) ->

130+ Just (Qualified _ (AliasValue alias)) ->

99 maybe id rethrowWithPosition pos $

131 maybe id rethrowWithPosition pos $

100− throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias)

132+ throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias

101− Just (Right alias) ->

133+ Just (Qualified mn' (AliasConstructor alias)) ->

102− return (pos, ConstructorBinder alias [lhs, rhs])

134+ return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])

103− Nothing ->

135+ _ ->

104 maybe id rethrowWithPosition pos $

136 maybe id rethrowWithPosition pos $

105 throwError . errorMessage $ UnknownValue name

137 throwError . errorMessage $ UnknownValue name

106 goBinder _ (BinaryNoParensBinder {}) =

138 goBinder _ (BinaryNoParensBinder {}) =

107 internalError "BinaryNoParensBinder has no OpBinder"

139 internalError "BinaryNoParensBinder has no OpBinder"

108 goBinder pos other = return (pos, other)

140 goBinder pos other = return (pos, other)

109

141

142+ goType :: Maybe SourceSpan -> Type -> m Type

143+ goType pos = everywhereOnTypesM go

144+ where

145+ go :: Type -> m Type

146+ go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of

147+ Just (Qualified mn' (AliasType alias)) ->

148+ return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs

149+ _ ->

150+ maybe id rethrowWithPosition pos $

151+ throwError . errorMessage $ UnknownTypeOp name

152+ go other = return other

153+

110removeSignedLiterals :: Module -> Module

154removeSignedLiterals :: Module -> Module

111removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

155removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

112 where

156 where

@@ -116,24 +160,64 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)

116 go other = other

160 go other = other

117

161

118rebracketModule

162rebracketModule

163+ :: forall m

119− :: (MonadError MultipleErrors m)

164+ . (MonadError MultipleErrors m)

120 => [[(Qualified Ident, Associativity)]]

165 => [[(Qualified Ident, Associativity)]]

166+ -> [[(Qualified Ident, Associativity)]]

121 -> Module

167 -> Module

122 -> m Module

168 -> m Module

123−rebracketModule opTable (Module ss coms mn ds exts) =

169+rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =

124− let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)

125− in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

170+ Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

171+ where

172+ (f, _, _) =

173+ everywhereOnValuesTopDownM

174+ (decontextify goDecl)

175+ (goExpr <=< decontextify goExpr')

176+ goBinder

177+

178+ (goDecl, goExpr') = updateTypes (\_ -> goType)

179+

180+ goExpr :: Expr -> m Expr

181+ goExpr = return . matchExprOperators valueOpTable

182+

183+ goBinder :: Binder -> m Binder

184+ goBinder = return . matchBinderOperators valueOpTable

185+

186+ goType :: Type -> m Type

187+ goType = return . matchTypeOperators typeOpTable

188+

189+ decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a

190+ decontextify ctxf = fmap snd . ctxf Nothing

126

191

127removeParens :: Declaration -> Declaration

192removeParens :: Declaration -> Declaration

128−removeParens =

193+removeParens = f

129− let (f, _, _) = everywhereOnValues id goExpr goBinder

130− in f

131 where

194 where

195+ (f, _, _) =

196+ everywhereOnValues

197+ (decontextify goDecl)

198+ (goExpr . decontextify goExpr')

199+ goBinder

200+

201+ (goDecl, goExpr') = updateTypes (\_ -> return . goType)

202+

203+ goExpr :: Expr -> Expr

132 goExpr (Parens val) = val

204 goExpr (Parens val) = val

133 goExpr val = val

205 goExpr val = val

206+

207+ goBinder :: Binder -> Binder

134 goBinder (ParensInBinder b) = b

208 goBinder (ParensInBinder b) = b

135 goBinder b = b

209 goBinder b = b

136

210

211+ goType :: Type -> Type

212+ goType (ParensInType t) = t

213+ goType t = t

214+

215+ decontextify

216+ :: (Maybe SourceSpan -> a -> Identity (Maybe SourceSpan, a))

217+ -> a

218+ -> a

219+ decontextify ctxf = snd . runIdentity . ctxf Nothing

220+

137externsFixities

221externsFixities

138 :: ExternsFile

222 :: ExternsFile

139 -> [FixityRecord]

223 -> [FixityRecord]

@@ -197,3 +281,52 @@ desugarOperatorSections (Module ss coms mn ds exts) =

197 Left val -> f2 val var

281 Left val -> f2 val var

198 Right val -> f2 var val

282 Right val -> f2 var val

199 goExpr other = return other

283 goExpr other = return other

284+

285+updateTypes

286+ :: forall m

287+ . Monad m

288+ => (Maybe SourceSpan -> Type -> m Type)

289+ -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)

290+ , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

291+ )

292+updateTypes goType = (goDecl, goExpr)

293+ where

294+

295+ goType' :: Maybe SourceSpan -> Type -> m Type

296+ goType' = everywhereOnTypesM . goType

297+

298+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)

299+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)

300+ goDecl pos (DataDeclaration ddt name args dctors) = do

301+ dctors' <- traverse (sndM (traverse (goType' pos))) dctors

302+ return (pos, DataDeclaration ddt name args dctors')

303+ goDecl pos (ExternDeclaration name ty) = do

304+ ty' <- goType' pos ty

305+ return (pos, ExternDeclaration name ty')

306+ goDecl pos (TypeClassDeclaration name args implies decls) = do

307+ implies' <- traverse (sndM (traverse (goType' pos))) implies

308+ return (pos, TypeClassDeclaration name args implies' decls)

309+ goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do

310+ cs' <- traverse (sndM (traverse (goType' pos))) cs

311+ tys' <- traverse (goType' pos) tys

312+ return (pos, TypeInstanceDeclaration name cs' className tys' impls)

313+ goDecl pos (TypeSynonymDeclaration name args ty) = do

314+ ty' <- goType' pos ty

315+ return (pos, TypeSynonymDeclaration name args ty')

316+ goDecl pos (TypeDeclaration expr ty) = do

317+ ty' <- goType' pos ty

318+ return (pos, TypeDeclaration expr ty')

319+ goDecl pos other = return (pos, other)

320+

321+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

322+ goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

323+ goExpr pos (TypeClassDictionary (name, tys) dicts) = do

324+ tys' <- traverse (goType' pos) tys

325+ return (pos, TypeClassDictionary (name, tys') dicts)

326+ goExpr pos (SuperClassDictionary cls tys) = do

327+ tys' <- traverse (goType' pos) tys

328+ return (pos, SuperClassDictionary cls tys')

329+ goExpr pos (TypedValue check v ty) = do

330+ ty' <- goType' pos ty

331+ return (pos, TypedValue check v ty')

332+ goExpr pos other = return (pos, other)

src/Language/PureScript/Sugar/Operators/Binders.hs+14−30

@@ -1,43 +1,27 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−

4module Language.PureScript.Sugar.Operators.Binders where

1module Language.PureScript.Sugar.Operators.Binders where

5

2

6import Prelude ()

3import Prelude ()

7import Prelude.Compat

4import Prelude.Compat

8

5

9−import Control.Monad.Error.Class (MonadError(..))

10−

11−import qualified Text.Parsec as P

12−import qualified Text.Parsec.Expr as P

13−

14−import Language.PureScript.Crash

15import Language.PureScript.AST

6import Language.PureScript.AST

16−import Language.PureScript.Errors

17import Language.PureScript.Names

7import Language.PureScript.Names

18import Language.PureScript.Sugar.Operators.Common

8import Language.PureScript.Sugar.Operators.Common

19

9

20−matchBinderOperators

21− :: forall m

22− . MonadError MultipleErrors m

23− => [[(Qualified Ident, Associativity)]]

10+matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder

24− -> Binder

25− -> m Binder

26−matchBinderOperators ops = parseChains

11+matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id

27 where

12 where

28− parseChains :: Binder -> m Binder

13+

14+ isBinOp :: Binder -> Bool

29− parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b)

15+ isBinOp BinaryNoParensBinder{} = True

30− parseChains other = return other

16+ isBinOp _ = False

31− extendChain :: Binder -> Chain Binder

17+

18+ extractOp :: Binder -> Maybe (Binder, Binder, Binder)

32− extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r

19+ extractOp (BinaryNoParensBinder op l r) = Just (op, l, r)

33− extendChain other = [Left other]

20+ extractOp _ = Nothing

34− bracketChain :: Chain Binder -> m Binder

21+

35− bracketChain =

22+ fromOp :: Binder -> Maybe (Qualified Ident)

36− either

37− (\_ -> internalError "matchBinderOperators: cannot reorder operators")

38− return

39− . P.parse opParser "operator expression"

40− opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof

41 fromOp (OpBinder q@(Qualified _ (Op _))) = Just q

23 fromOp (OpBinder q@(Qualified _ (Op _))) = Just q

42 fromOp _ = Nothing

24 fromOp _ = Nothing

25+

26+ reapply :: Qualified Ident -> Binder -> Binder -> Binder

43 reapply = BinaryNoParensBinder . OpBinder

27 reapply = BinaryNoParensBinder . OpBinder

src/Language/PureScript/Sugar/Operators/Common.hs+31

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

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE PatternGuards #-}

3

4

4module Language.PureScript.Sugar.Operators.Common where

5module Language.PureScript.Sugar.Operators.Common where

5

6

@@ -15,6 +16,7 @@ import qualified Text.Parsec.Pos as P

15import qualified Text.Parsec.Expr as P

16import qualified Text.Parsec.Expr as P

16

17

17import Language.PureScript.AST

18import Language.PureScript.AST

19+import Language.PureScript.Crash

18import Language.PureScript.Names

20import Language.PureScript.Names

19

21

20type Chain a = [Either a a]

22type Chain a = [Either a a]

@@ -51,3 +53,32 @@ opTable

51opTable ops fromOp reapply =

53opTable ops fromOp reapply =

52 map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops

54 map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops

53 ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]

55 ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]

56+

57+matchOperators

58+ :: forall a

59+ . Show a

60+ => (a -> Bool)

61+ -> (a -> Maybe (a, a, a))

62+ -> (a -> Maybe (Qualified Ident))

63+ -> (Qualified Ident -> a -> a -> a)

64+ -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a)

65+ -> [[(Qualified Ident, Associativity)]]

66+ -> a

67+ -> a

68+matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains

69+ where

70+ parseChains :: a -> a

71+ parseChains ty

72+ | True <- isBinOp ty = bracketChain (extendChain ty)

73+ | otherwise = ty

74+ extendChain :: a -> Chain a

75+ extendChain ty

76+ | Just (op, l, r) <- extractOp ty = Left l : Right op : extendChain r

77+ | otherwise = [Left ty]

78+ bracketChain :: Chain a -> a

79+ bracketChain =

80+ either

81+ (\_ -> internalError "matchTypeOperators: cannot reorder operators")

82+ id

83+ . P.parse opParser "operator expression"

84+ opParser = P.buildExpressionParser (modOpTable (opTable ops fromOp reapply)) parseValue <* P.eof

src/Language/PureScript/Sugar/Operators/Expr.hs+27−31

@@ -6,47 +6,43 @@ module Language.PureScript.Sugar.Operators.Expr where

6import Prelude ()

7import Prelude.Compat

8

9−import Control.Monad.Error.Class (MonadError(..))

9+import Data.Functor.Identity

10

11import qualified Text.Parsec as P

12import qualified Text.Parsec.Expr as P

13

14−import Language.PureScript.Crash

15import Language.PureScript.AST

14import Language.PureScript.AST

16−import Language.PureScript.Errors

17import Language.PureScript.Names

15import Language.PureScript.Names

18import Language.PureScript.Sugar.Operators.Common

16import Language.PureScript.Sugar.Operators.Common

19

17

20−matchExprOperators

21− :: forall m

22− . MonadError MultipleErrors m

23− => [[(Qualified Ident, Associativity)]]

18+matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr

24− -> Expr

19+matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable

25− -> m Expr

26−matchExprOperators ops = parseChains

27 where

20 where

28− parseChains :: Expr -> m Expr

21+

29− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

22+ isBinOp :: Expr -> Bool

30− parseChains other = return other

23+ isBinOp BinaryNoParens{} = True

31− extendChain :: Expr -> Chain Expr

24+ isBinOp _ = False

25+

26+ extractOp :: Expr -> Maybe (Expr, Expr, Expr)

32− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

27+ extractOp (BinaryNoParens op l r) = Just (op, l, r)

33− extendChain other = [Left other]

28+ extractOp _ = Nothing

34− bracketChain :: Chain Expr -> m Expr

29+

35− bracketChain =

30+ fromOp :: Expr -> Maybe (Qualified Ident)

36− either

37− (\_ -> internalError "matchExprOperators: cannot reorder operators")

38− return

39− . P.parse opParser "operator expression"

40− opParser = P.buildExpressionParser opTable' parseValue <* P.eof

41− opTable' =

42− [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ]

43− : opTable ops fromOp reapply

44 fromOp (Var q@(Qualified _ (Op _))) = Just q

31 fromOp (Var q@(Qualified _ (Op _))) = Just q

45 fromOp _ = Nothing

32 fromOp _ = Nothing

33+

34+ reapply :: Qualified Ident -> Expr -> Expr -> Expr

46 reapply op t1 t2 = App (App (Var op) t1) t2

35 reapply op t1 t2 = App (App (Var op) t1) t2

47

36

37+ modOpTable

38+ :: [[P.Operator (Chain Expr) () Identity Expr]]

39+ -> [[P.Operator (Chain Expr) () Identity Expr]]

40+ modOpTable table =

41+ [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ]

42+ : table

43+

48−parseTicks :: P.Parsec (Chain Expr) () Expr

44+ parseTicks :: P.Parsec (Chain Expr) () Expr

49−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

45+ parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

50− where

46+ where

51− fromOther (Var (Qualified _ (Op _))) = Nothing

47+ fromOther (Var (Qualified _ (Op _))) = Nothing

52− fromOther v = Just v

48+ fromOther v = Just v

src/Language/PureScript/Sugar/Operators/Types.hsnew file+28

@@ -0,0 +1,28 @@

1+module Language.PureScript.Sugar.Operators.Types where

2+

3+import Prelude ()

4+import Prelude.Compat

5+

6+import Language.PureScript.AST

7+import Language.PureScript.Names

8+import Language.PureScript.Sugar.Operators.Common

9+import Language.PureScript.Types

10+

11+matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type

12+matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id

13+ where

14+

15+ isBinOp :: Type -> Bool

16+ isBinOp BinaryNoParensType{} = True

17+ isBinOp _ = False

18+

19+ extractOp :: Type -> Maybe (Type, Type, Type)

20+ extractOp (BinaryNoParensType op l r) = Just (op, l, r)

21+ extractOp _ = Nothing

22+

23+ fromOp :: Type -> Maybe (Qualified Ident)

24+ fromOp (TypeOp q@(Qualified _ (Op _))) = Just q

25+ fromOp _ = Nothing

26+

27+ reapply :: Qualified Ident -> Type -> Type -> Type

28+ reapply = BinaryNoParensType . TypeOp

src/Language/PureScript/TypeChecker.hs+10−12

@@ -277,15 +277,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

277 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

278

279 checkFixities :: Declaration -> m ()

280− checkFixities (FixityDeclaration _ name (Just (Left alias))) = do

280+ checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do

281− ty <- lookupVariable moduleName alias

281+ ty <- lookupVariable moduleName (Qualified mn' ident)

282 addValue moduleName (Op name) ty Public

283− checkFixities (FixityDeclaration _ name (Just (Right alias))) = do

283+ checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do

284 env <- getEnv

285+ let alias = Qualified mn' ctor

285 case M.lookup alias (dataConstructors env) of

286 case M.lookup alias (dataConstructors env) of

286 Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing

287 Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing

287 Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public

288 Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public

288− checkFixities (FixityDeclaration _ name _) = do

289+ checkFixities (FixityDeclaration _ name Nothing) = do

289 env <- getEnv

290 env <- getEnv

290 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

291 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

291 checkFixities (PositionedDeclaration pos _ d) =

292 checkFixities (PositionedDeclaration pos _ d) =

@@ -438,21 +439,18 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

438 checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()

439 checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()

439 checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =

440 checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =

440 case listToMaybe (mapMaybe getAlias decls) of

441 case listToMaybe (mapMaybe getAlias decls) of

441− Just (Left ident) ->

442+ Just (AliasValue ident) ->

442 unless (ValueRef ident `elem` exps) $

443 unless (ValueRef ident `elem` exps) $

443 throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]

444 throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]

444− Just (Right ctor) ->

445+ Just (AliasConstructor ctor) ->

445 unless (ctor `elem` exportedDctors) $

446 unless (ctor `elem` exportedDctors) $

446 throwError . errorMessage $ TransitiveDctorExportError dr ctor

447 throwError . errorMessage $ TransitiveDctorExportError dr ctor

447 _ -> return ()

448 _ -> return ()

448 where

449 where

449− getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))

450+ getAlias :: Declaration -> Maybe FixityAlias

450 getAlias (PositionedDeclaration _ _ d) = getAlias d

451 getAlias (PositionedDeclaration _ _ d) = getAlias d

451− getAlias (FixityDeclaration _ name' (Just alias)) | name == name' =

452+ getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))

452− case alias of

453+ | name == name' && mn == mn' = Just alias

453− Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident)

454− Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor)

455− _ -> Nothing

456 getAlias _ = Nothing

454 getAlias _ = Nothing

457 checkNonAliasesAreExported _ _ = return ()

455 checkNonAliasesAreExported _ _ = return ()

458

456

src/Language/PureScript/TypeChecker/Kinds.hs+1−1

@@ -268,4 +268,4 @@ infer' other = (, []) <$> go other

268 k <- go ty

269 unifyKinds k Star

270 return Star

271− go _ = internalError "Invalid argument to infer"

271+ go ty = internalError $ "Invalid argument to infer: " ++ show ty

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

@@ -319,7 +319,7 @@ infer' (TypedValue checkType val ty) = do

319infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

320 TypedValue t v ty <- infer' val

321 return $ TypedValue t (PositionedValue pos c v) ty

322−infer' _ = internalError "Invalid argument to infer"

322+infer' v = internalError $ "Invalid argument to infer: " ++ show v

323

324inferLetBinding ::

325 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

src/Language/PureScript/Types.hs+34

@@ -49,6 +49,11 @@ data Type

49 --

50 | TypeConstructor (Qualified (ProperName 'TypeName))

51 -- |

52+ -- A type operator. This will be desugared into a type constructor during the

53+ -- "operators" phase of desugaring.

54+ --

55+ | TypeOp (Qualified Ident)

56+ -- |

52 -- A type application

57 -- A type application

53 --

58 --

54 | TypeApp Type Type

59 | TypeApp Type Type

@@ -89,6 +94,19 @@ data Type

89 -- A placeholder used in pretty printing

94 -- A placeholder used in pretty printing

90 --

95 --

91 | PrettyPrintForAll [String] Type

96 | PrettyPrintForAll [String] Type

97+ -- |

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

99+ -- this data constructor will be removed.

100+ --

101+ | BinaryNoParensType Type Type Type

102+ -- |

103+ -- Explicit parentheses. During the rebracketing phase of desugaring, this

104+ -- data constructor will be removed.

105+ --

106+ -- Note: although it seems this constructor is not used, it _is_ useful,

107+ -- since it prevents certain traversals from matching.

108+ --

109+ | ParensInType Type

92 deriving (Show, Read, Eq, Ord)

110 deriving (Show, Read, Eq, Ord)

93

111

94-- |

112-- |

@@ -154,6 +172,8 @@ replaceAllTypeVars = go []

154 go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)

172 go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)

155 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

173 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

156 go bs m (KindedType t k) = KindedType (go bs m t) k

174 go bs m (KindedType t k) = KindedType (go bs m t) k

175+ go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3)

176+ go bs m (ParensInType t) = ParensInType (go bs m t)

157 go _ _ ty = ty

177 go _ _ ty = ty

158

178

159 genName orig inUse = try 0

179 genName orig inUse = try 0

@@ -184,6 +204,8 @@ freeTypeVariables = nub . go []

184 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t

204 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t

185 go bound (RCons _ t r) = go bound t ++ go bound r

205 go bound (RCons _ t r) = go bound t ++ go bound r

186 go bound (KindedType t _) = go bound t

206 go bound (KindedType t _) = go bound t

207+ go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3

208+ go bound (ParensInType t) = go bound t

187 go _ _ = []

209 go _ _ = []

188

210

189-- |

211-- |

@@ -233,6 +255,8 @@ everywhereOnTypes f = go

233 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

255 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

234 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

256 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

235 go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))

257 go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))

258+ go (BinaryNoParensType t1 t2 t3) = f (BinaryNoParensType (go t1) (go t2) (go t3))

259+ go (ParensInType t) = f (ParensInType (go t))

236 go other = f other

260 go other = f other

237

261

238everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type

262everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type

@@ -246,6 +270,8 @@ everywhereOnTypesTopDown f = go . f

246 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

270 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

247 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

271 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

248 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

272 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

273+ go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3))

274+ go (ParensInType t) = ParensInType (f (go t))

249 go other = f other

275 go other = f other

250

276

251everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type

277everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type

@@ -259,6 +285,8 @@ everywhereOnTypesM f = go

259 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

285 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

260 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f

286 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f

261 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

287 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

288+ go (BinaryNoParensType t1 t2 t3) = (BinaryNoParensType <$> go t1 <*> go t2 <*> go t3) >>= f

289+ go (ParensInType t) = (ParensInType <$> go t) >>= f

262 go other = f other

290 go other = f other

263

291

264everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type

292everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type

@@ -272,6 +300,8 @@ everywhereOnTypesTopDownM f = go <=< f

272 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

300 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

273 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)

301 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)

274 go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)

302 go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)

303+ go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go)

304+ go (ParensInType t) = ParensInType <$> (f t >>= go)

275 go other = f other

305 go other = f other

276

306

277everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

307everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

@@ -285,6 +315,8 @@ everythingOnTypes (<>) f = go

285 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

315 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

286 go t@(PrettyPrintObject t1) = f t <> go t1

316 go t@(PrettyPrintObject t1) = f t <> go t1

287 go t@(PrettyPrintForAll _ t1) = f t <> go t1

317 go t@(PrettyPrintForAll _ t1) = f t <> go t1

318+ go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3

319+ go t@(ParensInType t1) = f t <> go t1

288 go other = f other

320 go other = f other

289

321

290everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r

322everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r

@@ -299,4 +331,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0

299 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

331 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

300 go s (PrettyPrintObject t1) = go' s t1

332 go s (PrettyPrintObject t1) = go' s t1

301 go s (PrettyPrintForAll _ t1) = go' s t1

333 go s (PrettyPrintForAll _ t1) = go' s t1

334+ go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3

335+ go s (ParensInType t1) = go' s t1

302 go _ _ = r0

336 go _ _ = r0

tests/Language/PureScript/Ide/Integration.hs+14

@@ -27,11 +27,13 @@ module Language.PureScript.Ide.Integration

27 , projectDirectory

28 , deleteFileIfExists

29 -- sending commands

30+ , loadModule

30 , loadModuleWithDeps

31 , loadModuleWithDeps

31 , getFlexCompletions

32 , getFlexCompletions

32 , getType

33 , getType

33 , addImport

34 , addImport

34 , addImplicitImport

35 , addImplicitImport

36+ , rebuildModule

35 -- checking results

37 -- checking results

36 , resultIsSuccess

38 , resultIsSuccess

37 , parseCompletions

39 , parseCompletions

@@ -131,6 +133,9 @@ quitServer = do

131loadModuleWithDeps :: String -> IO String

133loadModuleWithDeps :: String -> IO String

132loadModuleWithDeps m = sendCommand $ load [] [m]

134loadModuleWithDeps m = sendCommand $ load [] [m]

133

135

136+loadModule :: String -> IO String

137+loadModule m = sendCommand $ load [m] []

138+

134getFlexCompletions :: String -> IO [(String, String, String)]

139getFlexCompletions :: String -> IO [(String, String, String)]

135getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)))

140getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)))

136

141

@@ -143,6 +148,9 @@ addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)

143addImplicitImport :: String -> FilePath -> FilePath -> IO String

148addImplicitImport :: String -> FilePath -> FilePath -> IO String

144addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)

149addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)

145

150

151+rebuildModule :: FilePath -> IO String

152+rebuildModule m = sendCommand (rebuildC m Nothing)

153+

146-- Command Encoding

154-- Command Encoding

147

155

148commandWrapper :: String -> Value -> Value

156commandWrapper :: String -> Value -> Value

@@ -166,6 +174,12 @@ addImplicitImportC mn = addImportW $

166 , "module" .= mn

174 , "module" .= mn

167 ]

175 ]

168

176

177+rebuildC :: FilePath -> Maybe FilePath -> Value

178+rebuildC file outFile =

179+ commandWrapper "rebuild" (object [ "file" .= file

180+ , "outfile" .= outFile

181+ ])

182+

169addImportW :: Value -> FilePath -> FilePath -> Value

183addImportW :: Value -> FilePath -> FilePath -> Value

170addImportW importCommand fp outfp =

184addImportW importCommand fp outfp =

171 commandWrapper "import" (object [ "file" .= fp

185 commandWrapper "import" (object [ "file" .= fp

tests/Language/PureScript/Ide/RebuildSpec.hsnew file+62

@@ -0,0 +1,62 @@

1+module Language.PureScript.Ide.RebuildSpec where

2+

3+import Control.Monad

4+import qualified Language.PureScript.Ide.Integration as Integration

5+import Test.Hspec

6+

7+import System.FilePath

8+

9+compile :: IO ()

10+compile = do

11+ Integration.deleteOutputFolder

12+ s <- Integration.compileTestProject

13+ unless s $ fail "Failed to compile .purs sources"

14+

15+teardown :: IO ()

16+teardown = Integration.quitServer

17+

18+restart :: IO ()

19+restart = Integration.quitServer *> (void Integration.startServer)

20+

21+shouldBeSuccess :: String -> IO ()

22+shouldBeSuccess = shouldBe True . Integration.resultIsSuccess

23+

24+shouldBeFailure :: String -> IO ()

25+shouldBeFailure = shouldBe False . Integration.resultIsSuccess

26+

27+spec :: Spec

28+spec = beforeAll_ compile $ afterAll_ teardown $ before_ restart $ do

29+ describe "Rebuilding single modules" $ do

30+ it "rebuilds a correct module without dependencies successfully" $ do

31+ _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule"

32+ pdir <- Integration.projectDirectory

33+ let file = pdir </> "src" </> "RebuildSpecSingleModule.purs"

34+ Integration.rebuildModule file >>= shouldBeSuccess

35+ it "fails to rebuild an incorrect module without dependencies and returns the errors" $ do

36+ pdir <- Integration.projectDirectory

37+ let file = pdir </> "src" </> "RebuildSpecSingleModule.fail"

38+ Integration.rebuildModule file >>= shouldBeFailure

39+ it "rebuilds a correct module with its dependencies successfully" $ do

40+ _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps"

41+ pdir <- Integration.projectDirectory

42+ let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"

43+ Integration.rebuildModule file >>= shouldBeSuccess

44+ it "rebuilds a correct module that has reverse dependencies" $ do

45+ _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps"

46+ pdir <- Integration.projectDirectory

47+ let file = pdir </> "src" </> "RebuildSpecDep.purs"

48+ Integration.rebuildModule file >>= shouldBeSuccess

49+ it "fails to rebuild a module if its dependencies are not loaded" $ do

50+ _ <- Integration.loadModule "RebuildSpecWithDeps"

51+ pdir <- Integration.projectDirectory

52+ let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"

53+ Integration.rebuildModule file >>= shouldBeFailure

54+ it "rebuilds a correct module with a foreign file" $ do

55+ _ <- Integration.loadModuleWithDeps "RebuildSpecWithForeign"

56+ pdir <- Integration.projectDirectory

57+ let file = pdir </> "src" </> "RebuildSpecWithForeign.purs"

58+ Integration.rebuildModule file >>= shouldBeSuccess

59+ it "fails to rebuild a module with a foreign import but no file" $ do

60+ pdir <- Integration.projectDirectory

61+ let file = pdir </> "src" </> "RebuildSpecWithMissingForeign.fail"

62+ Integration.rebuildModule file >>= shouldBeFailure

tests/Main.hs+5

@@ -27,8 +27,13 @@ import qualified TestDocs

27import qualified TestPsci

28import qualified TestPscIde

29

30+import System.IO (hSetEncoding, stdout, stderr, utf8)

31+

30main :: IO ()

32main :: IO ()

31main = do

33main = do

34+ hSetEncoding stdout utf8

35+ hSetEncoding stderr utf8

36+

32 heading "Main compiler test suite"

37 heading "Main compiler test suite"

33 TestCompiler.main

38 TestCompiler.main

34 heading "Documentation test suite"

39 heading "Documentation test suite"

tests/TestDocs.hs+6−6

@@ -285,12 +285,12 @@ testCases =

285 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))

286 ])

287

288− , ("ConstrainedArgument",

288+ --, ("ConstrainedArgument",

289− [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"

289+ -- [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"

290− , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"

290+ -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"

291− , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"

291+ -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"

292− , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"

292+ -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"

293− ])

293+ -- ])

294 ]

295

296 where

tests/support/pscide/src/RebuildSpecDep.pursnew file+3

@@ -0,0 +1,3 @@

1+module RebuildSpecDep where

2+

3+dep = 42

tests/support/pscide/src/RebuildSpecSingleModule.failnew file+3

@@ -0,0 +1,3 @@

1+module RebuildSpecSingleModule where

2+

3+let anerror

tests/support/pscide/src/RebuildSpecSingleModule.pursnew file+4

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

1+module RebuildSpecSingleModule where

2+

3+id x = x

4+const x y = x

tests/support/pscide/src/RebuildSpecWithDeps.pursnew file+5

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

1+module RebuildSpecWithDeps where

2+

3+import RebuildSpecDep (dep)

4+

5+x = dep

tests/support/pscide/src/RebuildSpecWithForeign.jsnew file+3

@@ -0,0 +1,3 @@

1+// module RebuildSpecWithForeign

2+

3+exports.f = 5;

tests/support/pscide/src/RebuildSpecWithForeign.pursnew file+3

@@ -0,0 +1,3 @@

1+module RebuildSpecWithForeign where

2+

3+foreign import f :: Int

tests/support/pscide/src/RebuildSpecWithMissingForeign.failnew file+3

@@ -0,0 +1,3 @@

1+module RebuildSpecWithMissingForeign where

2+

3+foreign import f :: Int