1235127 · rowtype-yoga/purescript-native

.travis.yml+7−7

compare with golang

unifiedsplit

@@ -39,13 +39,13 @@ matrix:

39 sudo: required

40 env: BUILD_TYPE=haddock

41

42− - compiler: cc-osx-lts-normal

42+ # - compiler: cc-osx-lts-normal

43− os: osx

43+ # os: osx

44− env: BUILD_TYPE=normal DEPLOY=true

44+ # env: BUILD_TYPE=normal DEPLOY=true

45−

45+

46− - compiler: cc-osx-lts-sdist

46+ # - compiler: cc-osx-lts-sdist

47− os: osx

47+ # os: osx

48− env: BUILD_TYPE=sdist

48+ # env: BUILD_TYPE=sdist

49addons:

50 apt:

51 packages:

CONTRIBUTORS.md+3

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

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

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

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

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

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

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

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

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

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

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

@@ -87,6 +88,8 @@ This file lists the contributors to the PureScript compiler project, and the ter

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

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

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

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

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

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

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

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

90

93

91### Companies

94### Companies

92

95

examples/failing/2601.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldFailWith KindsDoNotUnify

2+module Main where

3+

4+type Syn (a :: * -> *) = String

5+

6+val :: Syn Int

7+val = "bad"

examples/passing/NestedRecordUpdate.purs+6−5

@@ -3,21 +3,22 @@ module Main where

3import Prelude

4import Control.Monad.Eff.Console

5

6−type T = { foo :: Int, bar :: { baz :: Int, qux :: Int } }

6+type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } }

7

8init :: T

9−init = { foo: 1, bar: { baz: 2, qux: 3 } }

9+init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } }

10

11updated :: T

12−updated = init { foo = 10, bar.baz = 20, bar.qux = 30 }

12+updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } }

13

14expected :: T

15−expected = { foo: 10, bar: { baz: 20, qux: 30 } }

15+expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } }

16

17check l r =

18 l.foo == r.foo &&

19 l.bar.baz == r.bar.baz &&

20− l.bar.qux == r.bar.qux

20+ l.bar.qux.lhs == r.bar.qux.lhs &&

21+ l.bar.qux.rhs == r.bar.qux.rhs

21

22

22main = do

23main = do

23 when (check updated expected) $ log "Done"

24 when (check updated expected) $ log "Done"

examples/passing/NestedRecordUpdateWildcards.purs+1−1

@@ -3,7 +3,7 @@ module Main where

3import Prelude

4import Control.Monad.Eff.Console

5

6−update = _ { foo = _, bar.baz = _, bar.qux = _ }

6+update = _ { foo = _, bar { baz = _, qux = _ } }

7

8init = { foo: 1, bar: { baz: 2, qux: 3 } }

9

examples/passing/ParseNamedBinder.pursdeleted−9

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

1−module Main where

2−

3−import Control.Monad.Eff.Console (log)

4−

5−data X = X

6−

7−f a@X X = a

8−

9−main = log "Done"

psc-package/Main.hs+35−32

@@ -28,9 +28,12 @@ import GHC.Generics (Generic)

28import qualified Options.Applicative as Opts

29import qualified Paths_purescript as Paths

30import qualified System.IO as IO

31−import Turtle hiding (fold, s, x)

31+import Turtle hiding (echo, fold, s, x)

32import qualified Turtle

33

34+echoT :: Text -> IO ()

35+echoT = Turtle.printf (Turtle.s % "\n")

36+

34packageFile :: Path.FilePath

37packageFile :: Path.FilePath

35packageFile = "psc-package.json"

38packageFile = "psc-package.json"

36

39

@@ -56,12 +59,12 @@ readPackageFile :: IO PackageConfig

56readPackageFile = do

59readPackageFile = do

57 exists <- testfile packageFile

60 exists <- testfile packageFile

58 unless exists $ do

61 unless exists $ do

59− echo "psc-package.json does not exist"

62+ echoT "psc-package.json does not exist"

60 exit (ExitFailure 1)

63 exit (ExitFailure 1)

61 mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile

64 mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile

62 case mpkg of

65 case mpkg of

63 Nothing -> do

66 Nothing -> do

64− echo "Unable to parse psc-package.json"

67+ echoT "Unable to parse psc-package.json"

65 exit (ExitFailure 1)

68 exit (ExitFailure 1)

66 Just pkg -> return pkg

69 Just pkg -> return pkg

67

70

@@ -124,13 +127,13 @@ listRemoteTags

124 :: Text

127 :: Text

125 -- ^ repo

128 -- ^ repo

126 -> Turtle.Shell Text

129 -> Turtle.Shell Text

127−listRemoteTags from =

130+listRemoteTags from = let gitProc = inproc "git"

128− inproc "git"

129− [ "ls-remote"

131+ [ "ls-remote"

130− , "-q"

132+ , "-q"

131− , "-t"

133+ , "-t"

132− , from

134+ , from

133− ] empty

135+ ] empty

136+ in lineToText <$> gitProc

134

137

135getPackageSet :: PackageConfig -> IO ()

138getPackageSet :: PackageConfig -> IO ()

136getPackageSet PackageConfig{ source, set } = do

139getPackageSet PackageConfig{ source, set } = do

@@ -143,12 +146,12 @@ readPackageSet PackageConfig{ set } = do

143 let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"

146 let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"

144 exists <- testfile dbFile

147 exists <- testfile dbFile

145 unless exists $ do

148 unless exists $ do

146− echo $ format (fp%" does not exist") dbFile

149+ echoT $ format (fp%" does not exist") dbFile

147 exit (ExitFailure 1)

150 exit (ExitFailure 1)

148 mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile

151 mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile

149 case mdb of

152 case mdb of

150 Nothing -> do

153 Nothing -> do

151− echo "Unable to parse packages.json"

154+ echoT "Unable to parse packages.json"

152 exit (ExitFailure 1)

155 exit (ExitFailure 1)

153 Just db -> return db

156 Just db -> return db

154

157

@@ -159,7 +162,7 @@ writePackageSet PackageConfig{ set } =

159

162

160installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath

163installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath

161installOrUpdate set pkgName PackageInfo{ repo, version } = do

164installOrUpdate set pkgName PackageInfo{ repo, version } = do

162− echo ("Updating " <> pkgName)

165+ echoT ("Updating " <> pkgName)

163 let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version

166 let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version

164 exists <- testdir pkgDir

167 exists <- testdir pkgDir

165 unless exists . void $ cloneShallow repo version pkgDir

168 unless exists . void $ cloneShallow repo version pkgDir

@@ -170,7 +173,7 @@ getTransitiveDeps db depends = do

170 pkgs <- for depends $ \pkg ->

173 pkgs <- for depends $ \pkg ->

171 case Map.lookup pkg db of

174 case Map.lookup pkg db of

172 Nothing -> do

175 Nothing -> do

173− echo ("Package " <> pkg <> " does not exist in package set")

176+ echoT ("Package " <> pkg <> " does not exist in package set")

174 exit (ExitFailure 1)

177 exit (ExitFailure 1)

175 Just PackageInfo{ dependencies } -> return (pkg : dependencies)

178 Just PackageInfo{ dependencies } -> return (pkg : dependencies)

176 let unique = Set.toList (foldMap Set.fromList pkgs)

179 let unique = Set.toList (foldMap Set.fromList pkgs)

@@ -181,16 +184,16 @@ updateImpl config@PackageConfig{ depends } = do

181 getPackageSet config

184 getPackageSet config

182 db <- readPackageSet config

185 db <- readPackageSet config

183 trans <- getTransitiveDeps db depends

186 trans <- getTransitiveDeps db depends

184− echo ("Updating " <> pack (show (length trans)) <> " packages...")

187+ echoT ("Updating " <> pack (show (length trans)) <> " packages...")

185 for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg

188 for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg

186

189

187initialize :: IO ()

190initialize :: IO ()

188initialize = do

191initialize = do

189 exists <- testfile "psc-package.json"

192 exists <- testfile "psc-package.json"

190 when exists $ do

193 when exists $ do

191− echo "psc-package.json already exists"

194+ echoT "psc-package.json already exists"

192 exit (ExitFailure 1)

195 exit (ExitFailure 1)

193− echo "Initializing new project in current directory"

196+ echoT "Initializing new project in current directory"

194 pkgName <- pathToTextUnsafe . Path.filename <$> pwd

197 pkgName <- pathToTextUnsafe . Path.filename <$> pwd

195 let pkg = defaultPackage pkgName

198 let pkg = defaultPackage pkgName

196 writePackageFile pkg

199 writePackageFile pkg

@@ -200,7 +203,7 @@ update :: IO ()

200update = do

203update = do

201 pkg <- readPackageFile

204 pkg <- readPackageFile

202 updateImpl pkg

205 updateImpl pkg

203− echo "Update complete"

206+ echoT "Update complete"

204

207

205install :: String -> IO ()

208install :: String -> IO ()

206install pkgName = do

209install pkgName = do

@@ -208,7 +211,7 @@ install pkgName = do

208 let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }

211 let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }

209 updateImpl pkg'

212 updateImpl pkg'

210 writePackageFile pkg'

213 writePackageFile pkg'

211− echo "psc-package.json file was updated"

214+ echoT "psc-package.json file was updated"

212

215

213uninstall :: String -> IO ()

216uninstall :: String -> IO ()

214uninstall pkgName = do

217uninstall pkgName = do

@@ -216,20 +219,20 @@ uninstall pkgName = do

216 let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }

219 let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }

217 updateImpl pkg'

220 updateImpl pkg'

218 writePackageFile pkg'

221 writePackageFile pkg'

219− echo "psc-package.json file was updated"

222+ echoT "psc-package.json file was updated"

220

223

221listDependencies :: IO ()

224listDependencies :: IO ()

222listDependencies = do

225listDependencies = do

223 pkg@PackageConfig{ depends } <- readPackageFile

226 pkg@PackageConfig{ depends } <- readPackageFile

224 db <- readPackageSet pkg

227 db <- readPackageSet pkg

225 trans <- getTransitiveDeps db depends

228 trans <- getTransitiveDeps db depends

226− traverse_ (echo . fst) trans

229+ traverse_ (echoT . fst) trans

227

230

228listPackages :: IO ()

231listPackages :: IO ()

229listPackages = do

232listPackages = do

230 pkg <- readPackageFile

233 pkg <- readPackageFile

231 db <- readPackageSet pkg

234 db <- readPackageSet pkg

232− traverse_ echo (fmt <$> Map.assocs db)

235+ traverse_ echoT (fmt <$> Map.assocs db)

233 where

236 where

234 fmt :: (Text, PackageInfo) -> Text

237 fmt :: (Text, PackageInfo) -> Text

235 fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"

238 fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"

@@ -251,7 +254,7 @@ listSourcePaths = do

251 pkg@PackageConfig{ depends } <- readPackageFile

254 pkg@PackageConfig{ depends } <- readPackageFile

252 db <- readPackageSet pkg

255 db <- readPackageSet pkg

253 paths <- getSourcePaths pkg db depends

256 paths <- getSourcePaths pkg db depends

254− traverse_ (echo . pathToTextUnsafe) paths

257+ traverse_ (echoT . pathToTextUnsafe) paths

255

258

256exec :: Text -> IO ()

259exec :: Text -> IO ()

257exec exeName = do

260exec exeName = do

@@ -267,11 +270,11 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do

267 pkg <- readPackageFile

270 pkg <- readPackageFile

268 db <- readPackageSet pkg

271 db <- readPackageSet pkg

269

272

270− echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")

273+ echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")

271− echo "Warning: this could take some time!"

274+ echoT "Warning: this could take some time!"

272

275

273 newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do

276 newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do

274− echo ("Checking package " <> name)

277+ echoT ("Checking package " <> name)

275 tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list

278 tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list

276 let tags = mapMaybe parseTag tagLines

279 let tags = mapMaybe parseTag tagLines

277 newVersion <- case parseVersion version of

280 newVersion <- case parseVersion version of

@@ -280,7 +283,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do

280 case filter (isMinorReleaseFrom parts) tags of

283 case filter (isMinorReleaseFrom parts) tags of

281 [] -> pure version

284 [] -> pure version

282 minorReleases -> do

285 minorReleases -> do

283− echo ("New minor release available")

286+ echoT ("New minor release available")

284 case applyMinorUpdates of

287 case applyMinorUpdates of

285 True -> do

288 True -> do

286 let latestMinorRelease = maximum minorReleases

289 let latestMinorRelease = maximum minorReleases

@@ -290,7 +293,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do

290 case filter (isMajorReleaseFrom parts) tags of

293 case filter (isMajorReleaseFrom parts) tags of

291 [] -> applyMinor

294 [] -> applyMinor

292 newReleases -> do

295 newReleases -> do

293− echo ("New major release available")

296+ echoT ("New major release available")

294 case applyMajorUpdates of

297 case applyMajorUpdates of

295 True -> do

298 True -> do

296 let latestRelease = maximum newReleases

299 let latestRelease = maximum newReleases

@@ -298,7 +301,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do

298 False -> applyMinor

301 False -> applyMinor

299 in applyMajor

302 in applyMajor

300 _ -> do

303 _ -> do

301− echo "Unable to parse version string"

304+ echoT "Unable to parse version string"

302 pure version

305 pure version

303 pure (name, p { version = newVersion }))

306 pure (name, p { version = newVersion }))

304

307

@@ -345,15 +348,15 @@ verifyPackageSet = do

345 pkg <- readPackageFile

348 pkg <- readPackageFile

346 db <- readPackageSet pkg

349 db <- readPackageSet pkg

347

350

348− echo ("Verifying " <> pack (show (Map.size db)) <> " packages.")

351+ echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.")

349− echo "Warning: this could take some time!"

352+ echoT "Warning: this could take some time!"

350

353

351 let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo

354 let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo

352 paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db)

355 paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db)

353

356

354 for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do

357 for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do

355 let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths)

358 let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths)

356− echo ("Verifying package " <> name)

359+ echoT ("Verifying package " <> name)

357 let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)

360 let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)

358 procs "psc" srcGlobs empty

361 procs "psc" srcGlobs empty

359

362

purescript.cabal+8−8

@@ -374,7 +374,7 @@ executable psc

374 filepath -any,

375 Glob >= 0.7 && < 0.8,

376 mtl -any,

377− optparse-applicative >= 0.12.1,

377+ optparse-applicative >= 0.13.0,

378 parsec -any,

379 text -any,

380 time -any,

@@ -401,7 +401,7 @@ executable psci

401 haskeline >= 0.7.0.0,

402 http-types == 0.9.*,

403 mtl -any,

404− optparse-applicative >= 0.12.1,

404+ optparse-applicative >= 0.13.0,

405 parsec -any,

406 process -any,

407 stm >= 0.2.4.0,

@@ -427,7 +427,7 @@ executable psc-docs

427 filepath -any,

428 Glob -any,

429 mtl -any,

430− optparse-applicative >= 0.12.1,

430+ optparse-applicative >= 0.13.0,

431 process -any,

432 split -any,

433 text -any,

@@ -465,7 +465,7 @@ executable psc-package

465 optparse-applicative -any,

466 system-filepath -any,

467 text -any,

468− turtle <1.3

468+ turtle ==1.3.*

469 main-is: Main.hs

470 other-modules: Paths_purescript

471 buildable: True

@@ -479,7 +479,7 @@ executable psc-hierarchy

479 filepath -any,

480 Glob -any,

481 mtl -any,

482− optparse-applicative >= 0.12.1,

482+ optparse-applicative >= 0.13.0,

483 parsec -any,

484 process -any,

485 text -any

@@ -502,7 +502,7 @@ executable psc-bundle

502 filepath -any,

503 Glob -any,

504 mtl -any,

505− optparse-applicative >= 0.12.1,

505+ optparse-applicative >= 0.13.0,

506 sourcemap >= 0.1.6,

507 transformers -any,

508 transformers-compat -any,

@@ -524,7 +524,7 @@ executable psc-ide-server

524 monad-logger -any,

525 mtl -any,

526 network -any,

527− optparse-applicative >= 0.12.1,

527+ optparse-applicative >= 0.13.0,

528 protolude >= 0.1.6,

529 stm -any,

530 text -any,

@@ -541,7 +541,7 @@ executable psc-ide-client

541 bytestring -any,

542 mtl -any,

543 network -any,

544− optparse-applicative >= 0.12.1,

544+ optparse-applicative >= 0.13.0,

545 text -any

546 ghc-options: -Wall -O2

547 hs-source-dirs: psc-ide-client

src/Language/PureScript/AST/Declarations.hs+37−3

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

1{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveTraversable #-}

2

4

3-- |

5-- |

4-- Data types for modules and declarations

6-- Data types for modules and declarations

@@ -12,7 +14,6 @@ import Control.Monad.Identity

12import Data.Aeson.TH

14import Data.Aeson.TH

13import qualified Data.Map as M

15import qualified Data.Map as M

14import Data.Text (Text)

16import Data.Text (Text)

15−import Data.List.NonEmpty (NonEmpty(..))

16

17

17import Language.PureScript.AST.Binders

18import Language.PureScript.AST.Binders

18import Language.PureScript.AST.Literals

19import Language.PureScript.AST.Literals

@@ -587,10 +588,10 @@ data Expr

587 --

588 --

588 | ObjectUpdate Expr [(PSString, Expr)]

589 | ObjectUpdate Expr [(PSString, Expr)]

589 -- |

590 -- |

590− -- Object updates with nested support: `x { foo.bar = e }`

591+ -- Object updates with nested support: `x { foo { bar = e } }`

591 -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s

592 -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s

592 --

593 --

593− | ObjectUpdateNested Expr [(NonEmpty PSString, Expr)]

594+ | ObjectUpdateNested Expr (PathTree Expr)

594 -- |

595 -- |

595 -- Function introduction

596 -- Function introduction

596 --

597 --

@@ -706,5 +707,38 @@ data DoNotationElement

706 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

707 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

707 deriving (Show)

708 deriving (Show)

708

709

710+

711+-- For a record update such as:

712+--

713+-- x { foo = 0

714+-- , bar { baz = 1

715+-- , qux = 2 } }

716+--

717+-- We represent the updates as the `PathTree`:

718+--

719+-- [ ("foo", Leaf 3)

720+-- , ("bar", Branch [ ("baz", Leaf 1)

721+-- , ("qux", Leaf 2) ]) ]

722+--

723+-- Which we then convert to an expression representing the following:

724+--

725+-- let x' = x

726+-- in x' { foo = 0

727+-- , bar = x'.bar { baz = 1

728+-- , qux = 2 } }

729+--

730+-- The `let` here is required to prevent re-evaluating the object expression `x`.

731+-- However we don't generate this when using an anonymous argument for the object.

732+--

733+

734+newtype PathTree t = PathTree (AssocList PSString (PathNode t))

735+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

736+

737+data PathNode t = Leaf t | Branch (PathTree t)

738+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

739+

740+newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }

741+ deriving (Show, Eq, Ord, Foldable, Functor, Traversable)

742+

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

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

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

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

src/Language/PureScript/AST/Traversals.hs+7−7

@@ -48,7 +48,7 @@ everywhereOnValues f g h = (f', g', h')

48 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

49 g' (Accessor prop v) = g (Accessor prop (g' v))

50 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

51− g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (map (fmap g') vs))

51+ g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))

52 g' (Abs name v) = g (Abs name (g' v))

53 g' (App v1 v2) = g (App (g' v1) (g' v2))

54 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

@@ -116,7 +116,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

116 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

117 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

118 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119− g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119+ g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs

120 g' (Abs name v) = Abs name <$> (g v >>= g')

121 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

122 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

@@ -184,7 +184,7 @@ everywhereOnValuesM f g h = (f', g', h')

184 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

185 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

186 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

187− g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse (sndM g') vs) >>= g

187+ g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g

188 g' (Abs name v) = (Abs name <$> g' v) >>= g

189 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

190 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

@@ -257,7 +257,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

257 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

258 g' v@(Accessor _ v1) = g v <> g' v1

259 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

260− g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

260+ g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)

261 g' v@(Abs _ v1) = g v <> g' v1

262 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

263 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

@@ -335,7 +335,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

335 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

336 g' s (Accessor _ v1) = g'' s v1

337 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

338− g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

338+ g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)

339 g' s (Abs _ v1) = g'' s v1

340 g' s (App v1 v2) = g'' s v1 <> g'' s v2

341 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

@@ -415,7 +415,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

415 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

416 g' s (Accessor prop v) = Accessor prop <$> g'' s v

417 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

418− g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (sndM (g'' s)) vs

418+ g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs

419 g' s (Abs name v) = Abs name <$> g'' s v

420 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

421 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

@@ -506,7 +506,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

506 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

507 g' s (Accessor _ v1) = g'' s v1

508 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

509− g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

509+ g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs

510 g' s (Abs (Left name) v1) =

511 let s' = S.insert name s

512 in g'' s' v1

src/Language/PureScript/Crash.hs+27−11

@@ -1,11 +1,27 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ImplicitParams #-}

3+

1−module Language.PureScript.Crash where

4+module Language.PureScript.Crash where

2−

5+

3−import Prelude.Compat

6+import Prelude.Compat

4−

7+

8+import qualified GHC.Stack

9+

10+-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.

11+#if __GLASGOW_HASKELL__ >= 800

12+type HasCallStack = GHC.Stack.HasCallStack

13+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)

14+type HasCallStack = (?callStack :: GHC.Stack.CallStack)

15+#else

16+import GHC.Exts (Constraint)

17+-- CallStack wasn't present in GHC 7.10.1

18+type HasCallStack = (() :: Constraint)

19+#endif

20+

5−-- | Exit with an error message and a crash report link.

21+-- | Exit with an error message and a crash report link.

6−internalError :: String -> a

22+internalError :: HasCallStack => String -> a

7−internalError =

23+internalError =

8− error

24+ error

9− . ("An internal error occurred during compilation: " ++)

25+ . ("An internal error occurred during compilation: " ++)

10− . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")

26+ . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")

11− . show

27+ . show

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

@@ -43,7 +43,7 @@ import System.FilePath.Glob (glob)

43

44-- | Accepts a Commmand and runs it against psc-ide's State. This is the main

45-- entry point for the server.

46−handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) =>

46+handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) =>

47 Command -> m Success

48handleCommand c = case c of

49 Load [] ->

@@ -131,7 +131,7 @@ listAvailableModules = do

131 let cleaned = filter (`notElem` [".", ".."]) contents

132 return (ModuleList (map toS cleaned))

133

134−caseSplit :: (Ide m, MonadError PscIdeError m) =>

134+caseSplit :: (Ide m, MonadError IdeError m) =>

135 Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success

136caseSplit l b e csa t = do

137 patterns <- CS.makePattern l b e csa <$> CS.caseSplit t

@@ -139,7 +139,7 @@ caseSplit l b e csa t = do

139

140-- | Finds all the externs.json files inside the output folder and returns the

141-- corresponding Modulenames

142−findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName]

142+findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName]

143findAvailableExterns = do

144 oDir <- outputDirectory

145 unlessM (liftIO (doesDirectoryExist oDir))

@@ -169,7 +169,7 @@ findAllSourceFiles = do

169-- inserts their ASTs into the state. Finally kicks off an async worker, which

170-- populates Stage 2 and 3 of the state.

171loadModulesAsync

172− :: (Ide m, MonadError PscIdeError m, MonadLogger m)

172+ :: (Ide m, MonadError IdeError m, MonadLogger m)

173 => [P.ModuleName]

174 -> m Success

175loadModulesAsync moduleNames = do

@@ -185,7 +185,7 @@ loadModulesAsync moduleNames = do

185 pure tr

186

187loadModulesSync

188− :: (Ide m, MonadError PscIdeError m, MonadLogger m)

188+ :: (Ide m, MonadError IdeError m, MonadLogger m)

189 => [P.ModuleName]

190 -> m Success

191loadModulesSync moduleNames = do

@@ -194,7 +194,7 @@ loadModulesSync moduleNames = do

194 pure tr

195

196loadModules

197− :: (Ide m, MonadError PscIdeError m, MonadLogger m)

197+ :: (Ide m, MonadError IdeError m, MonadLogger m)

198 => [P.ModuleName]

199 -> m Success

200loadModules moduleNames = do

src/Language/PureScript/Ide/CaseSplit.hs+6−6

@@ -45,7 +45,7 @@ explicitAnnotations = WildcardAnnotations True

45noAnnotations :: WildcardAnnotations

46noAnnotations = WildcardAnnotations False

47

48−caseSplit :: (Ide m, MonadError PscIdeError m) =>

48+caseSplit :: (Ide m, MonadError IdeError m) =>

49 Text -> m [Constructor]

50caseSplit q = do

51 type' <- parseType' q

@@ -55,7 +55,7 @@ caseSplit q = do

55 let appliedCtors = map (second (map applyTypeVars)) ctors

56 pure appliedCtors

57

58−findTypeDeclaration :: (Ide m, MonadError PscIdeError m) =>

58+findTypeDeclaration :: (Ide m, MonadError IdeError m) =>

59 P.ProperName 'P.TypeName -> m ExternsDeclaration

60findTypeDeclaration q = do

61 efs <- getExternFiles

@@ -73,7 +73,7 @@ findTypeDeclaration' t ExternsFile{..} =

73 EDType tn _ _ -> tn == t

74 _ -> False) efDeclarations

75

76−splitTypeConstructor :: (MonadError PscIdeError m) =>

76+splitTypeConstructor :: (MonadError IdeError m) =>

77 P.Type -> m (P.ProperName 'P.TypeName, [P.Type])

78splitTypeConstructor = go []

79 where

@@ -105,7 +105,7 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)

105 where

106 makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)

107

108−addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text]

108+addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text]

109addClause s wca = do

110 (fName, fType) <- parseTypeDeclaration' s

111 let args = splitFunctionType fType

@@ -114,7 +114,7 @@ addClause s wca = do

114 " = ?" <> (T.strip . P.runIdent $ fName)

115 pure [s, template]

116

117−parseType' :: (MonadError PscIdeError m) =>

117+parseType' :: (MonadError IdeError m) =>

118 Text -> m P.Type

119parseType' s =

120 case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of

@@ -123,7 +123,7 @@ parseType' s =

123 throwError (GeneralError ("Parsing the splittype failed with:"

124 <> show err))

125

126−parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type)

126+parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type)

127parseTypeDeclaration' s =

128 let x = do

129 ts <- P.lex "" (toS s)

src/Language/PureScript/Ide/Error.hs+4−4

@@ -13,7 +13,7 @@

13-----------------------------------------------------------------------------

14

15module Language.PureScript.Ide.Error

16− ( PscIdeError(..)

16+ ( IdeError(..)

17 ) where

18

19import Data.Aeson

@@ -22,7 +22,7 @@ import Language.PureScript.Ide.Types (ModuleIdent)

22import Protolude

23import qualified Text.Parsec.Error as P

24

25−data PscIdeError

25+data IdeError

26 = GeneralError Text

27 | NotFound Text

28 | ModuleNotFound ModuleIdent

@@ -31,7 +31,7 @@ data PscIdeError

31 | RebuildError [JSONError]

32 deriving (Show, Eq)

33

34−instance ToJSON PscIdeError where

34+instance ToJSON IdeError where

35 toJSON (RebuildError errs) = object

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

37 , "result" .= errs

@@ -41,7 +41,7 @@ instance ToJSON PscIdeError where

41 , "result" .= textError err

42 ]

43

44−textError :: PscIdeError -> Text

44+textError :: IdeError -> Text

45textError (GeneralError msg) = msg

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

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

src/Language/PureScript/Ide/Externs.hs+4−4

@@ -28,13 +28,13 @@ import Data.Aeson (decodeStrict)

28import qualified Data.ByteString as BS

29import qualified Data.Map as Map

30import Data.Version (showVersion)

31−import Language.PureScript.Ide.Error (PscIdeError (..))

31+import Language.PureScript.Ide.Error (IdeError (..))

32import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Util

34

35import qualified Language.PureScript as P

36

37−readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>

37+readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) =>

38 FilePath -> m P.ExternsFile

39readExternFile fp = do

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

@@ -138,9 +138,9 @@ annotateModule (defs, types) decls =

138 IdeDeclTypeClass tc ->

139 annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)

140 IdeDeclValueOperator op ->

141− annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

141+ annotateValue (op ^. ideValueOpName . opNameT) (IdeDeclValueOperator op)

142 IdeDeclTypeOperator op ->

143− annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

143+ annotateType (op ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator op)

144 IdeDeclKind i ->

145 annotateKind (i ^. properNameT) (IdeDeclKind i)

146 where

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

@@ -39,7 +39,7 @@ import Language.PureScript.Ide.Filter

39import Language.PureScript.Ide.State

40import Language.PureScript.Ide.Types

41import Language.PureScript.Ide.Util

42−import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)

42+import System.IO.UTF8 (writeUTF8FileT)

43

44data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)

45 deriving (Eq, Show)

@@ -67,10 +67,10 @@ compImport (Import n i q) (Import n' i' q')

67

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

69-- lines after the imports)

70−parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>

70+parseImportsFromFile :: (MonadIO m, MonadError IdeError m) =>

71 FilePath -> m (P.ModuleName, [Text], [Import], [Text])

72parseImportsFromFile fp = do

73− file <- liftIO (readUTF8FileT fp)

73+ file <- ideReadFile fp

74 case sliceImportSection (T.lines file) of

75 Right res -> pure res

76 Left err -> throwError (GeneralError err)

@@ -147,7 +147,7 @@ moduleParse t = first show $ do

147 P.runTokenParser "<psc-ide>" P.parseModule tokens

148

149-- | Adds an implicit import like @import Prelude@ to a Sourcefile.

150−addImplicitImport :: (MonadIO m, MonadError PscIdeError m)

150+addImplicitImport :: (MonadIO m, MonadError IdeError m)

151 => FilePath -- ^ The Sourcefile read from

152 -> P.ModuleName -- ^ The module to import

153 -> m [Text]

@@ -170,7 +170,7 @@ addImplicitImport' imports mn =

170-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing

171-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude

172-- (bind, unit)"]@

173−addExplicitImport :: (MonadIO m, MonadError PscIdeError m) =>

173+addExplicitImport :: (MonadIO m, MonadError IdeError m) =>

174 FilePath -> IdeDeclaration -> P.ModuleName -> m [Text]

175addExplicitImport fp decl moduleName = do

176 (mn, pre, imports, post) <- parseImportsFromFile fp

@@ -249,7 +249,7 @@ updateAtFirstOrPrepend p t d l =

249--

250-- * If more than one possible imports are found, reports the possibilities as a

251-- list of completions.

252−addImportForIdentifier :: (Ide m, MonadError PscIdeError m)

252+addImportForIdentifier :: (Ide m, MonadError IdeError m)

253 => FilePath -- ^ The Sourcefile to read from

254 -> Text -- ^ The identifier to import

255 -> [Filter] -- ^ Filters to apply before searching for

src/Language/PureScript/Ide/Rebuild.hs+6−6

@@ -20,7 +20,7 @@ import Language.PureScript.Ide.Error

20import Language.PureScript.Ide.Logging

21import Language.PureScript.Ide.State

22import Language.PureScript.Ide.Types

23−import System.IO.UTF8 (readUTF8FileT)

23+import Language.PureScript.Ide.Util

24

25-- | Given a filepath performs the following steps:

26--

@@ -38,7 +38,7 @@ import System.IO.UTF8 (readUTF8FileT)

38-- warnings, and if rebuilding fails, returns a @RebuildError@ with the

39-- generated errors.

40rebuildFile

41− :: (Ide m, MonadLogger m, MonadError PscIdeError m)

41+ :: (Ide m, MonadLogger m, MonadError IdeError m)

42 => FilePath

43 -- ^ The file to rebuild

44 -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())

@@ -46,7 +46,7 @@ rebuildFile

46 -> m Success

47rebuildFile path runOpenBuild = do

48

49− input <- liftIO (readUTF8FileT path)

49+ input <- ideReadFile path

50

51 m <- case snd <$> P.parseModuleFromFile identity (path, input) of

52 Left parseError -> throwError

@@ -80,7 +80,7 @@ rebuildFile path runOpenBuild = do

80 pure (RebuildSuccess (toJSONErrors False P.Warning warnings))

81

82rebuildFileAsync

83− :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m)

83+ :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)

84 => FilePath -> m Success

85rebuildFileAsync fp = rebuildFile fp asyncRun

86 where

@@ -91,7 +91,7 @@ rebuildFileAsync fp = rebuildFile fp asyncRun

91 void (liftIO (async (runLogger ll (runReaderT action env))))

92

93rebuildFileSync

94− :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m)

94+ :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)

95 => FilePath -> m Success

96rebuildFileSync fp = rebuildFile fp syncRun

97 where

@@ -158,7 +158,7 @@ shushCodegen ma MakeActionsEnv{..} =

158-- module. Throws an error if there is a cyclic dependency within the

159-- ExternsFiles

160sortExterns

161− :: (Ide m, MonadError PscIdeError m)

161+ :: (Ide m, MonadError IdeError m)

162 => P.Module

163 -> ModuleMap P.ExternsFile

164 -> m [P.ExternsFile]

src/Language/PureScript/Ide/SourceFile.hs+7−4

@@ -28,14 +28,13 @@ import qualified Language.PureScript as P

28import Language.PureScript.Ide.Error

29import Language.PureScript.Ide.Types

30import Language.PureScript.Ide.Util

31−import System.IO.UTF8 (readUTF8FileT)

32

31

33parseModule

32parseModule

34− :: (MonadIO m)

33+ :: (MonadIO m, MonadError IdeError m)

35 => FilePath

34 => FilePath

36 -> m (Either FilePath (FilePath, P.Module))

35 -> m (Either FilePath (FilePath, P.Module))

37parseModule path = do

36parseModule path = do

38− contents <- liftIO (readUTF8FileT path)

37+ contents <- ideReadFile path

39 case P.parseModuleFromFile identity (path, contents) of

38 case P.parseModuleFromFile identity (path, contents) of

40 Left _ -> pure (Left path)

39 Left _ -> pure (Left path)

41 Right m -> pure (Right m)

40 Right m -> pure (Right m)

@@ -47,7 +46,7 @@ getImports (P.Module _ _ _ declarations _) =

47 isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)

46 isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)

48 isImport _ = Nothing

47 isImport _ = Nothing

49

48

50−getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>

49+getImportsForFile :: (MonadIO m, MonadError IdeError m) =>

51 FilePath -> m [ModuleImport]

50 FilePath -> m [ModuleImport]

52getImportsForFile fp = do

51getImportsForFile fp = do

53 moduleE <- parseModule fp

52 moduleE <- parseModule fp

@@ -106,6 +105,10 @@ extractSpans ss d = case d of

106 P.DataDeclaration _ name _ ctors ->

105 P.DataDeclaration _ name _ ctors ->

107 (IdeNSType (P.runProperName name), ss)

106 (IdeNSType (P.runProperName name), ss)

108 : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors

107 : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors

108+ P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) ->

109+ [(IdeNSValue (P.runOpName opName), ss)]

110+ P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) ->

111+ [(IdeNSType (P.runOpName opName), ss)]

109 P.ExternDeclaration ident _ ->

112 P.ExternDeclaration ident _ ->

110 [(IdeNSValue (P.runIdent ident), ss)]

113 [(IdeNSValue (P.runIdent ident), ss)]

111 P.ExternDataDeclaration name _ ->

114 P.ExternDataDeclaration name _ ->

src/Language/PureScript/Ide/Types.hs+4−4

@@ -145,7 +145,7 @@ data IdeState = IdeState

145 { ideStage1 :: Stage1

146 , ideStage2 :: Stage2

147 , ideStage3 :: Stage3

148− }

148+ } deriving (Show)

149

150emptyIdeState :: IdeState

151emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3

@@ -162,16 +162,16 @@ emptyStage3 = Stage3 M.empty Nothing

162data Stage1 = Stage1

163 { s1Externs :: ModuleMap P.ExternsFile

164 , s1Modules :: ModuleMap (P.Module, FilePath)

165− }

165+ } deriving (Show)

166

167data Stage2 = Stage2

168 { s2AstData :: AstData P.SourceSpan

169− }

169+ } deriving (Show, Eq)

170

171data Stage3 = Stage3

172 { s3Declarations :: ModuleMap [IdeDeclarationAnn]

173 , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)

174− }

174+ } deriving (Show)

175

176newtype Match a = Match (P.ModuleName, a)

177 deriving (Show, Eq, Functor)

src/Language/PureScript/Ide/Util.hs+15

@@ -27,6 +27,8 @@ module Language.PureScript.Ide.Util

27 , prettyTypeT

28 , properNameT

29 , identT

30+ , opNameT

31+ , ideReadFile

30 , module Language.PureScript.Ide.Logging

32 , module Language.PureScript.Ide.Logging

31 ) where

33 ) where

32

34

@@ -39,8 +41,10 @@ import qualified Data.Text as T

39import qualified Data.Text.Lazy as TL

41import qualified Data.Text.Lazy as TL

40import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

42import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

41import qualified Language.PureScript as P

43import qualified Language.PureScript as P

44+import Language.PureScript.Ide.Error

42import Language.PureScript.Ide.Logging

45import Language.PureScript.Ide.Logging

43import Language.PureScript.Ide.Types

46import Language.PureScript.Ide.Types

47+import System.IO.UTF8 (readUTF8FileT)

44

48

45identifierFromIdeDeclaration :: IdeDeclaration -> Text

49identifierFromIdeDeclaration :: IdeDeclaration -> Text

46identifierFromIdeDeclaration d = case d of

50identifierFromIdeDeclaration d = case d of

@@ -123,6 +127,17 @@ properNameT = iso P.runProperName P.ProperName

123identT :: Iso' P.Ident Text

127identT :: Iso' P.Ident Text

124identT = iso P.runIdent P.Ident

128identT = iso P.runIdent P.Ident

125

129

130+opNameT :: Iso' (P.OpName a) Text

131+opNameT = iso P.runOpName P.OpName

132+

133+ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text

134+ideReadFile fp = do

135+ contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp))

136+ either

137+ (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))

138+ pure

139+ contents

140+

126prettyTypeT :: P.Type -> Text

141prettyTypeT :: P.Type -> Text

127prettyTypeT =

142prettyTypeT =

128 T.unwords

143 T.unwords

src/Language/PureScript/Parser/Declarations.hs+23−13

@@ -17,13 +17,12 @@ import Prelude hiding (lex)

17

18import Control.Applicative

19import Control.Arrow ((+++))

20+import Control.Monad (foldM)

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

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

21import Control.Parallel.Strategies (withStrategy, parList, rseq)

22import Control.Parallel.Strategies (withStrategy, parList, rseq)

22−import Data.Bifunctor (first)

23import Data.Functor (($>))

24−import Data.List.NonEmpty (NonEmpty(..))

25−import qualified Data.List.NonEmpty as N

26import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

25+import qualified Data.Set as S

27import Data.Text (Text)

26import Data.Text (Text)

28import Language.PureScript.AST

27import Language.PureScript.AST

29import Language.PureScript.Environment

28import Language.PureScript.Environment

@@ -399,13 +398,17 @@ parseInfixExpr

399parseHole :: TokenParser Expr

398parseHole :: TokenParser Expr

400parseHole = Hole <$> holeLit

399parseHole = Hole <$> holeLit

401

400

402−parsePropertyUpdate :: TokenParser (NonEmpty PSString, Expr)

401+parsePropertyUpdate :: TokenParser (PSString, PathNode Expr)

403parsePropertyUpdate = do

402parsePropertyUpdate = do

404 name <- parseLabel

403 name <- parseLabel

405− rest <- P.many (indented *> dot *> indented *> parseLabel)

404+ updates <- parseShallowUpdate <|> parseNestedUpdate

406− _ <- indented *> equals

407− value <- indented *> parseValue

408− return (name :| rest, value)

405+ return (name, updates)

406+ where

407+ parseShallowUpdate :: TokenParser (PathNode Expr)

408+ parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue)

409+

410+ parseNestedUpdate :: TokenParser (PathNode Expr)

411+ parseNestedUpdate = Branch <$> parseUpdaterBodyFields

409

412

410parseAccessor :: Expr -> TokenParser Expr

413parseAccessor :: Expr -> TokenParser Expr

411parseAccessor (Constructor _) = P.unexpected "constructor"

414parseAccessor (Constructor _) = P.unexpected "constructor"

@@ -455,11 +458,18 @@ parseValue = withSourceSpan PositionedValue

455 ]

458 ]

456 ]

459 ]

457

460

458−parseUpdaterBody :: Expr -> TokenParser Expr

461+parseUpdaterBodyFields :: TokenParser (PathTree Expr)

462+parseUpdaterBodyFields = do

459−parseUpdaterBody v = objectUpdate <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate)))

463+ updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate))

464+ (_, tree) <- foldM insertUpdate (S.empty, []) updates

465+ return (PathTree (AssocList (reverse tree)))

460 where

466 where

461− objectUpdate xs | all (null . N.tail . fst) xs = ObjectUpdate v (map (first N.head) xs)

467+ insertUpdate (seen, xs) (key, node)

468+ | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key)

469+ | otherwise = return (S.insert key seen, (key, node) : xs)

470+

471+parseUpdaterBody :: Expr -> TokenParser Expr

462− | otherwise = ObjectUpdateNested v xs

472+parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields

463

473

464parseAnonymousArgument :: TokenParser Expr

474parseAnonymousArgument :: TokenParser Expr

465parseAnonymousArgument = underscore *> pure AnonymousArgument

475parseAnonymousArgument = underscore *> pure AnonymousArgument

@@ -487,7 +497,7 @@ parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder)

487parseVarOrNamedBinder :: TokenParser Binder

497parseVarOrNamedBinder :: TokenParser Binder

488parseVarOrNamedBinder = do

498parseVarOrNamedBinder = do

489 name <- parseIdent

499 name <- parseIdent

490− let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderNoParens)

500+ let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderAtom)

491 parseNamedBinder <|> return (VarBinder name)

501 parseNamedBinder <|> return (VarBinder name)

492

502

493parseNullBinder :: TokenParser Binder

503parseNullBinder :: TokenParser Binder

src/Language/PureScript/Pretty/JS.hs+15−9

@@ -122,22 +122,30 @@ literals = mkPattern' match'

122 [ return $ emit $ lbl <> ": "

123 , prettyPrintJS' js

124 ]

125− match (JSComment _ com js) = fmap mconcat $ sequence $

125+ match (JSComment _ com js) = mconcat <$> sequence

126+ [ mconcat <$> forM com comment

127+ , prettyPrintJS' js

128+ ]

129+ match (JSRaw _ js) = return $ emit js

130+ match _ = mzero

131+

132+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

133+ comment (LineComment com) = fmap mconcat $ sequence $

134+ [ return $ emit "\n"

135+ , currentIndent

136+ , return $ emit "//" <> emit com <> emit "\n"

137+ ]

138+ comment (BlockComment com) = fmap mconcat $ sequence $

126 [ return $ emit "\n"

139 [ return $ emit "\n"

127 , currentIndent

140 , currentIndent

128 , return $ emit "/**\n"

141 , return $ emit "/**\n"

129 ] ++

142 ] ++

130− map asLine (concatMap commentLines com) ++

143+ map asLine (T.lines com) ++

131 [ currentIndent

144 [ currentIndent

132 , return $ emit " */\n"

145 , return $ emit " */\n"

133 , currentIndent

146 , currentIndent

134− , prettyPrintJS' js

135 ]

147 ]

136 where

148 where

137− commentLines :: Comment -> [Text]

138− commentLines (LineComment s) = [s]

139− commentLines (BlockComment s) = T.lines s

140−

141 asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

149 asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

142 asLine s = do

150 asLine s = do

143 i <- currentIndent

151 i <- currentIndent

@@ -150,8 +158,6 @@ literals = mkPattern' match'

150 Nothing -> case T.uncons t of

158 Nothing -> case T.uncons t of

151 Just (x, xs) -> x `T.cons` removeComments xs

159 Just (x, xs) -> x `T.cons` removeComments xs

152 Nothing -> ""

160 Nothing -> ""

153− match (JSRaw _ js) = return $ emit js

154− match _ = mzero

155

161

156conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

162conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

157conditional = mkPattern match

163conditional = mkPattern match

src/Language/PureScript/Pretty/Values.hs+8−10

@@ -12,7 +12,6 @@ import Prelude.Compat

12import Control.Arrow (second)

13

14import qualified Data.Monoid as Monoid ((<>))

15−import Data.List.NonEmpty (NonEmpty(..))

16

15

17import qualified Data.Text as T

16import qualified Data.Text as T

18import Data.Text (Text)

17import Data.Text (Text)

@@ -48,11 +47,8 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

48 prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box

47 prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box

49 prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

48 prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

50

49

51−prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, Expr)] -> Box

50+prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box

52−prettyPrintObjectUpdate printKey d o ps =

53− prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' printEntry ps

54− where

55− printEntry (key, val) = printKey key <> text " = " <> prettyPrintValue (d - 1) val

51+prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val

56

52

57-- | Pretty-print an expression

53-- | Pretty-print an expression

58prettyPrintValue :: Int -> Expr -> Box

54prettyPrintValue :: Int -> Expr -> Box

@@ -63,10 +59,12 @@ prettyPrintValue d (IfThenElse cond th el) =

63 , text "else " <> prettyPrintValueAtom (d - 1) el

59 , text "else " <> prettyPrintValueAtom (d - 1) el

64 ])

60 ])

65prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)

61prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)

66−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintObjectUpdate (textT . prettyPrintObjectKey) d o ps

62+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps

67−prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintObjectUpdate printPath d o ps where

63+prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps

68− printPath (hd :| tl) = foldl combine (textT (prettyPrintObjectKey hd)) tl

64+ where

69− combine acc key = acc <> textT ("." Monoid.<> prettyPrintObjectKey key)

65+ prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree)

66+ printNode (key, Leaf val) = prettyPrintUpdateEntry d key val

67+ printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val

70prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

68prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

71prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

69prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

72prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

70prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

src/Language/PureScript/Sugar/ObjectWildcards.hs+26−88

@@ -5,46 +5,18 @@ module Language.PureScript.Sugar.ObjectWildcards

5

6import Prelude.Compat

7

8−import Control.Monad (forM, foldM)

8+import Control.Monad (forM)

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

10import Control.Monad.Supply.Class

11−import Data.List (partition)

11+import Data.Foldable (toList)

12−import Data.List.NonEmpty (NonEmpty(..))

12+import Data.List (foldl')

13−import Data.Map (Map)

14−import qualified Data.Map as M

15import Data.Maybe (catMaybes)

13import Data.Maybe (catMaybes)

16import Language.PureScript.AST

14import Language.PureScript.AST

17import Language.PureScript.Environment (NameKind(..))

15import Language.PureScript.Environment (NameKind(..))

18import Language.PureScript.Errors

16import Language.PureScript.Errors

19−import Language.PureScript.Label (Label(..))

20import Language.PureScript.Names

17import Language.PureScript.Names

21import Language.PureScript.PSString (PSString)

18import Language.PureScript.PSString (PSString)

22

19

23−-- `PathNode` and `PathTree` are used as an intermediate form when desugaring a nested object update.

24−-- For an update such as:

25−--

26−-- x { foo = 0

27−-- , bar.baz = 1

28−-- , bar.qux = 2 }

29−--

30−-- We represent the updates as the `PathTree`:

31−--

32−-- M.fromList [ ("foo", Leaf 3)

33−-- , ("bar", Branch (M.fromList [ ("baz", Leaf 1)

34−-- , ("qux", Leaf 2) ]) ])

35−--

36−-- Which we then convert to an expression representing the following:

37−--

38−-- let x' = x

39−-- in x' { foo = 0

40−-- , bar = x'.bar { baz = 1

41−-- , qux = 2 } }

42−--

43−-- The `let` here is required to prevent re-evaluating the object expression `x`.

44−-- However we don't generate this when using an anonymous argument for the object.

45−--

46−type PathTree = Map PSString PathNode

47−data PathNode = Leaf Expr | Branch PathTree

48

20

49desugarObjectConstructors

21desugarObjectConstructors

50 :: forall m

22 :: forall m

@@ -70,11 +42,7 @@ desugarDecl other = fn other

70 , BinaryNoParens op u val <- b'

42 , BinaryNoParens op u val <- b'

71 , isAnonymousArgument u = do arg <- freshIdent'

43 , isAnonymousArgument u = do arg <- freshIdent'

72 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

44 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

73− desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps

74− desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

75− obj <- freshIdent'

76− Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps

77− desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

78 desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

46 desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

79 desugarExpr (Accessor prop u)

47 desugarExpr (Accessor prop u)

80 | Just props <- peelAnonAccessorChain u = do

48 | Just props <- peelAnonAccessorChain u = do

@@ -92,67 +60,42 @@ desugarDecl other = fn other

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

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

93 desugarExpr e = return e

61 desugarExpr e = return e

94

62

95− transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr

63+ transformNestedUpdate :: Expr -> PathTree Expr -> m Expr

96 transformNestedUpdate obj ps = do

64 transformNestedUpdate obj ps = do

97 -- If we don't have an anonymous argument then we need to generate a let wrapper

65 -- If we don't have an anonymous argument then we need to generate a let wrapper

98 -- so that the object expression isn't re-evaluated for each nested update.

66 -- so that the object expression isn't re-evaluated for each nested update.

99 val <- freshIdent'

67 val <- freshIdent'

68+ let valExpr = argToExpr val

100 if isAnonymousArgument obj

69 if isAnonymousArgument obj

101− then Abs (Left val) <$> wrapLambdaM (build val) ps

70+ then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps

102− else wrapLambdaM (fmap (buildLet val) . build val) ps

71+ else wrapLambda (buildLet val . buildUpdates valExpr) ps

103 where

72 where

104− build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs

105 buildLet val = Let [ValueDeclaration val Public [] (Right obj)]

73 buildLet val = Let [ValueDeclaration val Public [] (Right obj)]

106

74

107− -- Here we build up the intermediate `PathTree` data structure and check that

108− -- the paths are valid relative to each other - for example, the update

109− -- `{ foo.bar = 2, foo = {bar: 3} }` is invalid because there are conflicting

110− -- paths.

111− buildTree

112− :: PathTree

113− -> (NonEmpty PSString, Expr)

114− -> m PathTree

115− buildTree pathTree (path, e) = go pathTree path where

116− go tree (key :| [])

117− -- path already exists

118− | key `M.member` tree = throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps))

119− -- create new path

120− | otherwise = return (M.insert key (Leaf e) tree)

121− go tree (key :| (x : xs)) = do

122− branch <- case M.lookup key tree of

123− -- nothing at this path yet

124− Nothing -> return M.empty

125− -- already a map at this path

126− Just (Branch branch) -> return branch

127− -- sub-path already exists

128− Just (Leaf _) -> throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps))

129− M.insert key . Branch <$> go branch (x :| xs) <*> pure tree

130−

131− -- Now we have a valid collection of updates in the form of a `PathTree`

132− -- we can recursively build up the nested `ObjectUpdate` expressions.

75+ -- recursively build up the nested `ObjectUpdate` expressions

133− buildUpdates :: Expr -> PathTree -> Expr

76+ buildUpdates :: Expr -> PathTree Expr -> Expr

134− buildUpdates val vs = ObjectUpdate val (goLayer [] <$> M.toList vs) where

77+ buildUpdates val (PathTree vs) = ObjectUpdate val (goLayer [] <$> runAssocList vs) where

135− goLayer :: [PSString] -> (PSString, PathNode) -> (PSString, Expr)

78+ goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)

136 goLayer _ (key, Leaf expr) = (key, expr)

79 goLayer _ (key, Leaf expr) = (key, expr)

137− goLayer path (key, Branch branch) =

80+ goLayer path (key, Branch (PathTree branch)) =

138 let path' = path ++ [key]

81 let path' = path ++ [key]

139− updates = goLayer path' <$> M.toList branch

82+ updates = goLayer path' <$> runAssocList branch

140− accessor = foldr Accessor val path'

83+ accessor = foldl' (flip Accessor) val path'

141 objectUpdate = ObjectUpdate accessor updates

84 objectUpdate = ObjectUpdate accessor updates

142 in (key, objectUpdate)

85 in (key, objectUpdate)

143

86

144− wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr

87+ wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr

145− wrapLambdaM mkVal ps =

88+ wrapLambda mkVal ps = do

146− let (args, props) = partition (isAnonymousArgument . snd) ps

89+ args <- traverse processExpr ps

147− in if null args

148− then mkVal props

149− else do

150− (args', ps') <- unzip <$> mapM mkProp ps

151− val <- mkVal ps'

152− return $ foldr (Abs . Left) val (catMaybes args')

90+ return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args))

91+ where

92+ processExpr :: Expr -> m (Maybe Ident, Expr)

93+ processExpr e = do

94+ arg <- freshIfAnon e

95+ return (arg, maybe e argToExpr arg)

153

96

154− wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr

97+ wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr

155− wrapLambda mkVal = wrapLambdaM (return . mkVal)

98+ wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList

156

99

157 stripPositionInfo :: Expr -> Expr

100 stripPositionInfo :: Expr -> Expr

158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

101 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

@@ -169,11 +112,6 @@ desugarDecl other = fn other

169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

112 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

170 isAnonymousArgument _ = False

113 isAnonymousArgument _ = False

171

114

172− mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr))

173− mkProp (name, e) = do

174− arg <- freshIfAnon e

175− return (arg, (name, maybe e argToExpr arg))

176−

177 freshIfAnon :: Expr -> m (Maybe Ident)

115 freshIfAnon :: Expr -> m (Maybe Ident)

178 freshIfAnon u

116 freshIfAnon u

179 | isAnonymousArgument u = Just <$> freshIdent'

117 | isAnonymousArgument u = Just <$> freshIdent'

stack-ghc-8.0.yaml+2

@@ -6,3 +6,5 @@ extra-deps:

6- wai-websockets-3.0.0.9

7- websockets-0.9.6.2

8- bower-json-1.0.0.1

9+- turtle-1.3.1

10+- optparse-applicative-0.13.0.0

stack.yaml+2

@@ -3,3 +3,5 @@ packages:

3- '.'

4extra-deps:

5- bower-json-1.0.0.1

6+- turtle-1.3.1

7+- optparse-applicative-0.13.0.0

tests/Language/PureScript/Ide/ImportsSpec.hs+1−1

@@ -190,7 +190,7 @@ importShouldBe :: [Text] -> [Text] -> Expectation

190importShouldBe res importSection =

191 res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"]

192

193−runIdeLoaded :: Command -> IO (Either PscIdeError Success)

193+runIdeLoaded :: Command -> IO (Either IdeError Success)

194runIdeLoaded c = do

195 ([_, result], _) <- Test.inProject $ Test.runIde [Command.LoadSync [] , c]

196 pure result

tests/Language/PureScript/Ide/SourceFileSpec.hs+28−2

@@ -16,7 +16,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)

16span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)

17span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)

18

19−typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration

19+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration

20typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty

21value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])

22synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty

@@ -25,6 +25,16 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []

25 [P.PositionedDeclaration span2 [] member1]

26data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []

27data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]

28+valueFixity =

29+ P.ValueFixityDeclaration

30+ (P.Fixity P.Infix 0)

31+ (P.Qualified Nothing (Left (P.Ident "")))

32+ (P.OpName "<$>")

33+typeFixity =

34+ P.TypeFixityDeclaration

35+ (P.Fixity P.Infix 0)

36+ (P.Qualified Nothing (P.ProperName ""))

37+ (P.OpName "~>")

28foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty

38foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty

29foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType

39foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType

30foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3")

40foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3")

@@ -45,6 +55,10 @@ spec = do

45 extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)]

55 extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)]

46 it "extracts spans for a data declaration and its constructors" $

56 it "extracts spans for a data declaration and its constructors" $

47 extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]

57 extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]

58+ it "extracts a span for a value operator fixity declaration" $

59+ extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNSValue "<$>", span1)]

60+ it "extracts a span for a type operator fixity declaration" $

61+ extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNSType "~>", span1)]

48 it "extracts a span for a foreign declaration" $

62 it "extracts a span for a foreign declaration" $

49 extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]

63 extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]

50 it "extracts a span for a data foreign declaration" $

64 it "extracts a span for a data foreign declaration" $

@@ -67,6 +81,12 @@ spec = do

67 it "finds a class declaration" $ do

81 it "finds a class declaration" $ do

68 Just r <- getLocation "SFClass"

82 Just r <- getLocation "SFClass"

69 r `shouldBe` classSS

83 r `shouldBe` classSS

84+ it "finds a value operator declaration" $ do

85+ Just r <- getLocation "<$>"

86+ r `shouldBe` valueOpSS

87+ it "finds a type operator declaration" $ do

88+ Just r <- getLocation "~>"

89+ r `shouldBe` typeOpSS

70

90

71getLocation :: Text -> IO (Maybe P.SourceSpan)

91getLocation :: Text -> IO (Maybe P.SourceSpan)

72getLocation s = do

92getLocation s = do

@@ -83,14 +103,20 @@ getLocation s = do

83 , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS

103 , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS

84 , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS

104 , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS

85 , ideTypeClass "SFClass" [] `annLoc` classSS

105 , ideTypeClass "SFClass" [] `annLoc` classSS

106+ , ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing

107+ `annLoc` valueOpSS

108+ , ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing

109+ `annLoc` typeOpSS

86 ])

110 ])

87 ]

111 ]

88

112

89−valueSS, synonymSS, typeSS, classSS :: P.SourceSpan

113+valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan

90valueSS = ss 3 1

114valueSS = ss 3 1

91synonymSS = ss 5 1

115synonymSS = ss 5 1

92typeSS = ss 7 1

116typeSS = ss 7 1

93classSS = ss 8 1

117classSS = ss 8 1

118+valueOpSS = ss 12 1

119+typeOpSS = ss 13 1

94

120

95ss :: Int -> Int -> P.SourceSpan

121ss :: Int -> Int -> P.SourceSpan

96ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y)

122ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y)

tests/Language/PureScript/Ide/Test.hs+2−2

@@ -24,7 +24,7 @@ defConfig =

24 , confGlobs = ["src/*.purs"]

25 }

26

27−runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either PscIdeError Success], IdeState)

27+runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState)

28runIde' conf s cs = do

29 stateVar <- newTVarIO s

30 let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf}

@@ -32,7 +32,7 @@ runIde' conf s cs = do

32 newState <- readTVarIO stateVar

33 pure (r, newState)

34

35−runIde :: [Command] -> IO ([Either PscIdeError Success], IdeState)

35+runIde :: [Command] -> IO ([Either IdeError Success], IdeState)

36runIde = runIde' defConfig emptyIdeState

37

38s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState

tests/support/pscide/src/SourceFileSpec.pursdeleted−10

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

1−module SourceFileSpec where

2−

3−sfValue = "sfValue"

4−

5−type SFType = String

6−

7−data SFData = SFOne | SFTwo | SFThree

8−

9−class SFClass a where

10− sfShow :: a -> String