3a976e4 · rowtype-yoga/purescript-native

examples/failing/2542.pursnew file+9

compare with golang

unifiedsplit

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

1+-- @shouldFailWith UndefinedTypeVariable

2+module Main where

3+

4+type T = forall a. Array a

5+

6+foo :: T

7+foo = bar where

8+ bar :: Array a

9+ bar = []

examples/failing/ImportModule.purs+1−1

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

1−-- @shouldFailWith UnknownName

1+-- @shouldFailWith ModuleNotFound

2module Main where

3

4import M1

examples/failing/MPTCs.purs+1−1

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

1−-- @shouldFailWith KindsDoNotUnify

1+-- @shouldFailWith ClassInstanceArityMismatch

2module Main where

3

4import Prelude

examples/failing/TooFewClassInstanceArgs.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith ClassInstanceArityMismatch

2+module Main where

3+

4+import Prelude

5+

6+class Foo a b

7+

8+instance fooString :: Foo String

examples/passing/2136.pursnew file+9

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

1+module Main where

2+

3+import Prelude

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

5+

6+main =

7+ if (negate (bottom :: Int) > top)

8+ then log "Fail"

9+ else log "Done"

examples/passing/2288.pursnew file+19

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

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

6+import Data.Array

7+import Data.Array.Partial as P

8+import Partial.Unsafe

9+

10+length :: forall a. Array a -> Int

11+length = go 0 where

12+ go acc arr =

13+ if null arr

14+ then acc

15+ else go (acc + 1) (unsafePartial P.tail arr)

16+

17+main = do

18+ logShow (length (1 .. 10000))

19+ log "Done"

examples/passing/NestedRecordUpdate.pursnew file+23

@@ -0,0 +1,23 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

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

7+

8+init :: T

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

10+

11+updated :: T

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

13+

14+expected :: T

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

16+

17+check l r =

18+ l.foo == r.foo &&

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

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

21+

22+main = do

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

examples/passing/NestedRecordUpdateWildcards.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

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

7+

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

9+

10+after = update init 10 20 30

11+

12+expected = { foo: 10, bar: { baz: 20, qux: 30 } }

13+

14+check l r =

15+ l.foo == r.foo &&

16+ l.bar.baz == r.bar.baz &&

17+ l.bar.qux == r.bar.qux

18+

19+main = do

20+ when (check after expected) $ log "Done"

examples/passing/ParseNamedBinder.pursnew file+9

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

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"

examples/warning/2542.pursnew file+16

@@ -0,0 +1,16 @@

1+-- @shouldWarnWith MissingTypeDeclaration

2+module Main where

3+

4+import Control.Monad.Eff.Console

5+

6+type T = forall a. Array a

7+

8+-- | Note: This should not raise a `ShadowedTypeVar` warning as the

9+-- | type `a` introduced in `T` should not be in scope

10+-- | in the definition of `bar`.

11+foo :: T

12+foo = bar where

13+ bar :: forall a. Array a

14+ bar = []

15+

16+main = log "Done"

examples/warning/CustomWarning.pursnew file+9

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

1+-- @shouldWarnWith UserDefinedWarning

2+module Main where

3+

4+foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t

5+foo x = x

6+

7+bar :: Int

8+bar = foo 42

9+

psc-docs/Main.hs+2−2

@@ -60,8 +60,8 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

60 Etags -> dumpTags input dumpEtags

61 Ctags -> dumpTags input dumpCtags

62 Markdown -> do

63− ms <- runExceptT (D.parseAndBookmark input []

63+ ms <- runExceptT (D.parseFilesInPackages input []

64− >>= (fst >>> D.convertModulesInPackage))

64+ >>= uncurry D.convertModulesInPackage)

65 >>= successOrExit

66

67 case output of

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

@@ -130,9 +130,9 @@ startServer port env = withSocketsDo $ do

130 where

131 loop :: (Ide m, MonadLogger m) => Socket -> m ()

132 loop sock = do

133− accepted <- runExceptT $ acceptCommand sock

133+ accepted <- runExceptT (acceptCommand sock)

134 case accepted of

135− Left err -> $(logDebug) err

135+ Left err -> $(logError) err

136 Right (cmd, h) -> do

137 case decodeT cmd of

138 Just cmd' -> do

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

147 Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r)

148 Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err)

149 Nothing -> do

150− $(logDebug) ("Parsing the command failed. Command: " <> cmd)

150+ $(logError) ("Parsing the command failed. Command: " <> cmd)

151 liftIO $ do

152 T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))

153 hFlush stdout

@@ -167,7 +167,7 @@ acceptCommand sock = do

167 case cmd' of

168 Nothing -> throwError "Connection was closed before any input arrived"

169 Just cmd -> do

170− $(logDebug) cmd

170+ $(logDebug) ("Received command: " <> cmd)

171 pure (cmd, h)

172 where

173 acceptConnection = liftIO $ do

purescript.cabal+4−2

@@ -128,6 +128,7 @@ library

128 containers -any,

129 clock -any,

130 data-ordlist >= 0.4.7.0,

131+ deepseq -any,

131 directory >= 1.2,

132 directory >= 1.2,

132 dlist -any,

133 dlist -any,

133 edit-distance -any,

134 edit-distance -any,

@@ -288,9 +289,10 @@ library

288 Language.PureScript.Docs.Types

289 Language.PureScript.Docs.Types

289 Language.PureScript.Docs.RenderedCode

290 Language.PureScript.Docs.RenderedCode

290 Language.PureScript.Docs.RenderedCode.Types

291 Language.PureScript.Docs.RenderedCode.Types

291− Language.PureScript.Docs.RenderedCode.Render

292+ Language.PureScript.Docs.RenderedCode.RenderType

293+ Language.PureScript.Docs.RenderedCode.RenderKind

292 Language.PureScript.Docs.AsMarkdown

294 Language.PureScript.Docs.AsMarkdown

293− Language.PureScript.Docs.ParseAndBookmark

295+ Language.PureScript.Docs.ParseInPackage

294 Language.PureScript.Docs.Utils.MonoidExtras

296 Language.PureScript.Docs.Utils.MonoidExtras

295

297

296 Language.PureScript.Publish

298 Language.PureScript.Publish

src/Language/PureScript/AST/Declarations.hs+12−2

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

12import Data.Aeson.TH

13import qualified Data.Map as M

14import Data.Text (Text)

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

15

16

16import Language.PureScript.AST.Binders

17import Language.PureScript.AST.Binders

17import Language.PureScript.AST.Literals

18import Language.PureScript.AST.Literals

@@ -43,7 +44,8 @@ data TypeSearch

43

44

44-- | A type of error messages

45-- | A type of error messages

45data SimpleErrorMessage

46data SimpleErrorMessage

47+ = ModuleNotFound ModuleName

46− = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

48+ | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

47 | ErrorParsingModule P.ParseError

49 | ErrorParsingModule P.ParseError

48 | MissingFFIModule ModuleName

50 | MissingFFIModule ModuleName

49 | MultipleFFIModules ModuleName [FilePath]

51 | MultipleFFIModules ModuleName [FilePath]

@@ -134,11 +136,14 @@ data SimpleErrorMessage

134 | CaseBinderLengthDiffers Int [Binder]

136 | CaseBinderLengthDiffers Int [Binder]

135 | IncorrectAnonymousArgument

137 | IncorrectAnonymousArgument

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

138 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

137− | DeprecatedRequirePath

138 | CannotGeneralizeRecursiveFunction Ident Type

139 | CannotGeneralizeRecursiveFunction Ident Type

139 | CannotDeriveNewtypeForData (ProperName 'TypeName)

140 | CannotDeriveNewtypeForData (ProperName 'TypeName)

140 | ExpectedWildcard (ProperName 'TypeName)

141 | ExpectedWildcard (ProperName 'TypeName)

141 | CannotUseBindWithDo

142 | CannotUseBindWithDo

143+ -- | instance name, type class, expected argument count, actual argument count

144+ | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int

145+ -- | a user-defined warning raised by using the Warn type class

146+ | UserDefinedWarning Type

142 deriving (Show)

147 deriving (Show)

143

148

144-- | Error message hints, providing more detailed information about failure.

149-- | Error message hints, providing more detailed information about failure.

@@ -582,6 +587,11 @@ data Expr

582 --

587 --

583 | ObjectUpdate Expr [(PSString, Expr)]

588 | ObjectUpdate Expr [(PSString, Expr)]

584 -- |

589 -- |

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

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

592+ --

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

594+ -- |

585 -- Function introduction

595 -- Function introduction

586 --

596 --

587 | Abs (Either Ident Binder) Expr

597 | Abs (Either Ident Binder) Expr

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

@@ -48,6 +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' (Abs name v) = g (Abs name (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

184 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= 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

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

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

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

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

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

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

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

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

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

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

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

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

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)

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

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

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

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

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

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

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

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

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

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

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

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

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)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

504 let s' = S.insert name s

511 let s' = S.insert name s

505 in g'' s' v1

512 in g'' s' v1

src/Language/PureScript/CodeGen/JS.hs+12−17

@@ -35,7 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),

35 errorMessage, rethrowWithPosition, addHint)

36import Language.PureScript.Names

37import Language.PureScript.Options

38−import Language.PureScript.PSString (PSString, mkString, decodeString)

38+import Language.PureScript.PSString (PSString, mkString)

39import Language.PureScript.Traversals (sndM)

40import qualified Language.PureScript.Constants as C

41

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

69 let standardExps = exps \\ foreignExps

70 let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps

71 ++ map (mkString . runIdent &&& foreignIdent) foreignExps

72− return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']

72+ return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps']

73

74 where

75

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

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

183

184 accessorString :: PSString -> JS -> JS

185− accessorString prop =

186− case decodeString prop of

187− Just s | not (identNeedsEscaping s) ->

188− JSAccessor Nothing s

189− _ ->

190− JSIndexer Nothing (JSStringLiteral Nothing prop)

185+ accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

191

186

192 -- |

187 -- |

193 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

188 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

@@ -201,9 +196,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

201 valueToJs' (Literal (pos, _, _, _) l) =

196 valueToJs' (Literal (pos, _, _, _) l) =

202 maybe id rethrowWithPosition pos $ literalToValueJS l

197 maybe id rethrowWithPosition pos $ literalToValueJS l

203 valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =

198 valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =

204− return $ JSAccessor Nothing "value" $ qualifiedToJS id name

199+ return $ accessorString "value" $ qualifiedToJS id name

205 valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =

200 valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =

206− return $ JSAccessor Nothing "create" $ qualifiedToJS id name

201+ return $ accessorString "create" $ qualifiedToJS id name

207 valueToJs' (Accessor _ prop val) =

202 valueToJs' (Accessor _ prop val) =

208 accessorString prop <$> valueToJs val

203 accessorString prop <$> valueToJs val

209 valueToJs' (ObjectUpdate _ o ps) = do

204 valueToJs' (ObjectUpdate _ o ps) = do

@@ -258,17 +253,17 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

258 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

253 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

259 valueToJs' (Constructor _ _ (ProperName ctor) []) =

254 valueToJs' (Constructor _ _ (ProperName ctor) []) =

260 return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])

255 return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])

261− , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))

256+ , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))

262 (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

257 (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

263 valueToJs' (Constructor _ _ (ProperName ctor) fields) =

258 valueToJs' (Constructor _ _ (ProperName ctor) fields) =

264 let constructor =

259 let constructor =

265− let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

260+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

266 in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

261 in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

267 createFn =

262 createFn =

268 let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

263 let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

269 in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

264 in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

270 in return $ iife (properToJs ctor) [ constructor

265 in return $ iife (properToJs ctor) [ constructor

271− , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn

266+ , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn

272 ]

267 ]

273

268

274 iife :: Text -> [JS] -> JS

269 iife :: Text -> [JS] -> JS

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

299 evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)

294 evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)

300 objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

295 objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

301 copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

296 copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

302− cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]

297+ cond = JSApp Nothing (accessorString "call" (accessorString "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]

303 assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]

298 assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]

304 stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js

299 stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js

305 extend = map stToAssign sts

300 extend = map stToAssign sts

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

356 valueError _ l@(JSNumericLiteral _ _) = l

351 valueError _ l@(JSNumericLiteral _ _) = l

357 valueError _ l@(JSStringLiteral _ _) = l

352 valueError _ l@(JSStringLiteral _ _) = l

358 valueError _ l@(JSBooleanLiteral _ _) = l

353 valueError _ l@(JSBooleanLiteral _ _) = l

359− valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s

354+ valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s

360

355

361 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

356 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

362 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

357 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

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

397 argVar <- freshName

392 argVar <- freshName

398 done'' <- go remain done'

393 done'' <- go remain done'

399 js <- binderToJs argVar done'' binder

394 js <- binderToJs argVar done'' binder

400− return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)

395+ return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js)

401 binderToJs' _ _ ConstructorBinder{} =

396 binderToJs' _ _ ConstructorBinder{} =

402 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

403 binderToJs' varName done (NamedBinder _ ident binder) = do

398 binderToJs' varName done (NamedBinder _ ident binder) = do

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

426 return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)

421 return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)

427 literalToBinderJS varName done (ArrayLiteral bs) = do

422 literalToBinderJS varName done (ArrayLiteral bs) = do

428 js <- go done 0 bs

423 js <- go done 0 bs

429− return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]

424+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]

430 where

425 where

431 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

426 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

432 go done' _ [] = return done'

427 go done' _ [] = return done'

src/Language/PureScript/CodeGen/JS/AST.hs−9

@@ -159,10 +159,6 @@ data JS

159 --

160 | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]

161 -- |

162− -- An object property accessor expression

163− --

164− | JSAccessor (Maybe SourceSpan) Text JS

165− -- |

166 -- A function introduction (optional name, arguments, body)

162 -- A function introduction (optional name, arguments, body)

167 --

163 --

168 | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS

164 | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS

@@ -259,7 +255,6 @@ withSourceSpan withSpan = go

259 go (JSArrayLiteral _ js) = JSArrayLiteral ss js

255 go (JSArrayLiteral _ js) = JSArrayLiteral ss js

260 go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2

256 go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2

261 go (JSObjectLiteral _ js) = JSObjectLiteral ss js

257 go (JSObjectLiteral _ js) = JSObjectLiteral ss js

262− go (JSAccessor _ prop j) = JSAccessor ss prop j

263 go (JSFunction _ name args j) = JSFunction ss name args j

258 go (JSFunction _ name args j) = JSFunction ss name args j

264 go (JSApp _ j js) = JSApp ss j js

259 go (JSApp _ j js) = JSApp ss j js

265 go (JSVar _ s) = JSVar ss s

260 go (JSVar _ s) = JSVar ss s

@@ -293,7 +288,6 @@ getSourceSpan = go

293 go (JSArrayLiteral ss _) = ss

288 go (JSArrayLiteral ss _) = ss

294 go (JSIndexer ss _ _) = ss

289 go (JSIndexer ss _ _) = ss

295 go (JSObjectLiteral ss _) = ss

290 go (JSObjectLiteral ss _) = ss

296− go (JSAccessor ss _ _) = ss

297 go (JSFunction ss _ _ _) = ss

291 go (JSFunction ss _ _ _) = ss

298 go (JSApp ss _ _) = ss

292 go (JSApp ss _ _) = ss

299 go (JSVar ss _) = ss

293 go (JSVar ss _) = ss

@@ -328,7 +322,6 @@ everywhereOnJS f = go

328 go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))

322 go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))

329 go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))

323 go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))

330 go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))

324 go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))

331− go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))

332 go (JSFunction ss name args j) = f (JSFunction ss name args (go j))

325 go (JSFunction ss name args j) = f (JSFunction ss name args (go j))

333 go (JSApp ss j js) = f (JSApp ss (go j) (map go js))

326 go (JSApp ss j js) = f (JSApp ss (go j) (map go js))

334 go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))

327 go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))

@@ -359,7 +352,6 @@ everywhereOnJSTopDownM f = f >=> go

359 go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js

352 go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js

360 go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2

353 go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2

361 go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js

354 go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js

362− go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j

363 go (JSFunction ss name args j) = JSFunction ss name args <$> f' j

355 go (JSFunction ss name args j) = JSFunction ss name args <$> f' j

364 go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js

356 go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js

365 go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3

357 go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3

@@ -386,7 +378,6 @@ everythingOnJS (<>) f = go

386 go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)

378 go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)

387 go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2

379 go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2

388 go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)

380 go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)

389− go j@(JSAccessor _ _ j1) = f j <> go j1

390 go j@(JSFunction _ _ _ j1) = f j <> go j1

381 go j@(JSFunction _ _ _ j1) = f j <> go j1

391 go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)

382 go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)

392 go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

383 go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

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

@@ -46,7 +46,7 @@ optimize js = do

46optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS

47optimize' js = do

48 opts <- ask

49− js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll

49+ js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll

50 [ inlineCommonValues

51 , inlineCommonOperators

52 ]) js

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

@@ -11,7 +11,7 @@ import Data.Maybe (fromMaybe)

11

12import Language.PureScript.Crash

13import Language.PureScript.CodeGen.JS.AST

14−import Language.PureScript.PSString (mkString)

14+import Language.PureScript.PSString (PSString)

15

16applyAll :: [a -> a] -> a -> a

17applyAll = foldl' (.) id

@@ -55,7 +55,6 @@ isUsed var1 = everythingOnJS (||) check

55

56targetVariable :: JS -> Text

57targetVariable (JSVar _ var) = var

58−targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

59targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

58targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

60targetVariable _ = internalError "Invalid argument to targetVariable"

59targetVariable _ = internalError "Invalid argument to targetVariable"

61

60

@@ -70,16 +69,10 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

70removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

69removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

71removeFromBlock _ js = js

70removeFromBlock _ js = js

72

71

73−isFn :: (Text, Text) -> JS -> Bool

72+isDict :: (Text, PSString) -> JS -> Bool

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

75− x == fnName && y == moduleName

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

73+isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =

77− x == mkString fnName && y == moduleName

78−isFn _ _ = False

79−

80−isDict :: (Text, Text) -> JS -> Bool

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

74+ x == dictName && y == moduleName

82isDict _ _ = False

75isDict _ _ = False

83

76

84−isDict' :: [(Text, Text)] -> JS -> Bool

77+isDict' :: [(Text, PSString)] -> JS -> Bool

85isDict' xs js = any (`isDict` js) xs

78isDict' xs js = any (`isDict` js) xs

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+84−68

@@ -6,6 +6,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner

6 , inlineCommonValues

7 , inlineCommonOperators

8 , inlineFnComposition

9+ , inlineUnsafePartial

9 , etaConvert

10 , etaConvert

10 , unThunk

11 , unThunk

11 , evaluateIifes

12 , evaluateIifes

@@ -17,9 +18,11 @@ import Control.Monad.Supply.Class (MonadSupply, freshName)

17

18

18import Data.Maybe (fromMaybe)

19import Data.Maybe (fromMaybe)

19import Data.Monoid ((<>))

20import Data.Monoid ((<>))

21+import Data.String (IsString, fromString)

20import Data.Text (Text)

22import Data.Text (Text)

21import qualified Data.Text as T

23import qualified Data.Text as T

22

24

25+import Language.PureScript.PSString (PSString)

23import Language.PureScript.CodeGen.JS.AST

26import Language.PureScript.CodeGen.JS.AST

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

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

25import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

@@ -33,7 +36,6 @@ shouldInline (JSVar _ _) = True

33shouldInline (JSNumericLiteral _ _) = True

36shouldInline (JSNumericLiteral _ _) = True

34shouldInline (JSStringLiteral _ _) = True

37shouldInline (JSStringLiteral _ _) = True

35shouldInline (JSBooleanLiteral _ _) = True

38shouldInline (JSBooleanLiteral _ _) = True

36−shouldInline (JSAccessor _ _ val) = shouldInline val

37shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val

39shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val

38shouldInline _ = False

40shouldInline _ = False

39

41

@@ -65,6 +67,8 @@ evaluateIifes = everywhereOnJS convert

65 where

67 where

66 convert :: JS -> JS

68 convert :: JS -> JS

67 convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret

69 convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret

70+ convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) [])

71+ | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret

68 convert js = js

72 convert js = js

69

73

70inlineVariables :: JS -> JS

74inlineVariables :: JS -> JS

@@ -82,15 +86,17 @@ inlineCommonValues = everywhereOnJS convert

82 where

86 where

83 convert :: JS -> JS

87 convert :: JS -> JS

84 convert (JSApp ss fn [dict])

88 convert (JSApp ss fn [dict])

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

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

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

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

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

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

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

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

93+ convert (JSApp ss (JSApp _ fn [dict]) [x])

94+ | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0))

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

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

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

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

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

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

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

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

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

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

94 convert other = other

100 convert other = other

95 fnZero = (C.dataSemiring, C.zero)

101 fnZero = (C.dataSemiring, C.zero)

96 fnOne = (C.dataSemiring, C.one)

102 fnOne = (C.dataSemiring, C.one)

@@ -100,6 +106,7 @@ inlineCommonValues = everywhereOnJS convert

100 fnDivide = (C.dataEuclideanRing, C.div)

106 fnDivide = (C.dataEuclideanRing, C.div)

101 fnMultiply = (C.dataSemiring, C.mul)

107 fnMultiply = (C.dataSemiring, C.mul)

102 fnSubtract = (C.dataRing, C.sub)

108 fnSubtract = (C.dataRing, C.sub)

109+ fnNegate = (C.dataRing, C.negate)

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

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

104

111

105inlineCommonOperators :: JS -> JS

112inlineCommonOperators :: JS -> JS

@@ -109,8 +116,6 @@ inlineCommonOperators = applyAll $

109

116

110 , binary ringNumber opSub Subtract

117 , binary ringNumber opSub Subtract

111 , unary ringNumber opNegate Negate

118 , unary ringNumber opNegate Negate

112− , binary ringInt opSub Subtract

113− , unary ringInt opNegate Negate

114

119

115 , binary euclideanRingNumber opDiv Divide

120 , binary euclideanRingNumber opDiv Divide

116 , binary euclideanRingInt opMod Modulus

121 , binary euclideanRingInt opMod Modulus

@@ -167,29 +172,29 @@ inlineCommonOperators = applyAll $

167 ] ++

172 ] ++

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

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

169 where

174 where

170− binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS

175+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS

171 binary dict fns op = everywhereOnJS convert

176 binary dict fns op = everywhereOnJS convert

172 where

177 where

173 convert :: JS -> JS

178 convert :: JS -> JS

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

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

175 convert other = other

180 convert other = other

176− binary' :: Text -> Text -> BinaryOperator -> JS -> JS

181+ binary' :: Text -> PSString -> BinaryOperator -> JS -> JS

177 binary' moduleName opString op = everywhereOnJS convert

182 binary' moduleName opString op = everywhereOnJS convert

178 where

183 where

179 convert :: JS -> JS

184 convert :: JS -> JS

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

185+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y

181 convert other = other

186 convert other = other

182− unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS

187+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS

183 unary dicts fns op = everywhereOnJS convert

188 unary dicts fns op = everywhereOnJS convert

184 where

189 where

185 convert :: JS -> JS

190 convert :: JS -> JS

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

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

187 convert other = other

192 convert other = other

188− unary' :: Text -> Text -> UnaryOperator -> JS -> JS

193+ unary' :: Text -> PSString -> UnaryOperator -> JS -> JS

189 unary' moduleName fnName op = everywhereOnJS convert

194 unary' moduleName fnName op = everywhereOnJS convert

190 where

195 where

191 convert :: JS -> JS

196 convert :: JS -> JS

192− convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x

197+ convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x

193 convert other = other

198 convert other = other

194 mkFn :: Int -> JS -> JS

199 mkFn :: Int -> JS -> JS

195 mkFn 0 = everywhereOnJS convert

200 mkFn 0 = everywhereOnJS convert

@@ -213,7 +218,8 @@ inlineCommonOperators = applyAll $

213

218

214 isNFn :: Text -> Int -> JS -> Bool

219 isNFn :: Text -> Int -> JS -> Bool

215 isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))

220 isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))

216− isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))

221+ isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried =

222+ name == fromString (T.unpack prefix <> show n)

217 isNFn _ _ _ = False

223 isNFn _ _ _ = False

218

224

219 runFn :: Int -> JS -> JS

225 runFn :: Int -> JS -> JS

@@ -234,20 +240,21 @@ inlineCommonOperators = applyAll $

234 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

240 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

235 convert other = other

241 convert other = other

236

242

237− isModFn :: (Text, Text) -> JS -> Bool

243+ isModFn :: (Text, PSString) -> JS -> Bool

238− isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

244+ isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) =

245+ m == m' && op == op'

239 isModFn _ _ = False

246 isModFn _ _ = False

240

247

241− isModFnWithDict :: (Text, Text) -> JS -> Bool

248+ isModFnWithDict :: (Text, PSString) -> JS -> Bool

242− isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op'

249+ isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) =

250+ m == m' && op == op'

243 isModFnWithDict _ _ = False

251 isModFnWithDict _ _ = False

244

252

245-- (f <<< g $ x) = f (g x)

253-- (f <<< g $ x) = f (g x)

246-- (f <<< g) = \x -> f (g x)

254-- (f <<< g) = \x -> f (g x)

247−inlineFnComposition :: (MonadSupply m) => JS -> m JS

255+inlineFnComposition :: forall m. MonadSupply m => JS -> m JS

248−inlineFnComposition = everywhereOnJSTopDownM convert

256+inlineFnComposition = everywhereOnJSTopDownM convert where

249− where

250− convert :: (MonadSupply m) => JS -> m JS

257+ convert :: JS -> m JS

251 convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])

258 convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])

252 | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]

259 | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]

253 | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]

260 | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]

@@ -260,118 +267,127 @@ inlineFnComposition = everywhereOnJSTopDownM convert

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

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

261 convert other = return other

268 convert other = return other

262 isFnCompose :: JS -> JS -> Bool

269 isFnCompose :: JS -> JS -> Bool

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

270+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn

264 isFnComposeFlipped :: JS -> JS -> Bool

271 isFnComposeFlipped :: JS -> JS -> Bool

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

272+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn

266− fnCompose :: (Text, Text)

273+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)

267 fnCompose = (C.controlSemigroupoid, C.compose)

274 fnCompose = (C.controlSemigroupoid, C.compose)

268− fnComposeFlipped :: (Text, Text)

275+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)

269 fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

276 fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

270

277

278+inlineUnsafePartial :: JS -> JS

279+inlineUnsafePartial = everywhereOnJSTopDown convert where

280+ convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ])

281+ | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe

282+ -- Apply to undefined here, the application should be optimized away

283+ -- if it is safe to do so

284+ = JSApp ss comp [ JSVar ss C.undefined ]

285+ convert other = other

286+

271−semiringNumber :: (Text, Text)

287+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

272semiringNumber = (C.dataSemiring, C.semiringNumber)

288semiringNumber = (C.dataSemiring, C.semiringNumber)

273

289

274−semiringInt :: (Text, Text)

290+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)

275semiringInt = (C.dataSemiring, C.semiringInt)

291semiringInt = (C.dataSemiring, C.semiringInt)

276

292

277−ringNumber :: (Text, Text)

293+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)

278ringNumber = (C.dataRing, C.ringNumber)

294ringNumber = (C.dataRing, C.ringNumber)

279

295

280−ringInt :: (Text, Text)

296+ringInt :: forall a b. (IsString a, IsString b) => (a, b)

281ringInt = (C.dataRing, C.ringInt)

297ringInt = (C.dataRing, C.ringInt)

282

298

283−euclideanRingNumber :: (Text, Text)

299+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)

284euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

300euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

285

301

286−euclideanRingInt :: (Text, Text)

302+euclideanRingInt :: forall a b. (IsString a, IsString b) => (a, b)

287euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)

303euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)

288

304

289−eqNumber :: (Text, Text)

305+eqNumber :: forall a b. (IsString a, IsString b) => (a, b)

290eqNumber = (C.dataEq, C.eqNumber)

306eqNumber = (C.dataEq, C.eqNumber)

291

307

292−eqInt :: (Text, Text)

308+eqInt :: forall a b. (IsString a, IsString b) => (a, b)

293eqInt = (C.dataEq, C.eqInt)

309eqInt = (C.dataEq, C.eqInt)

294

310

295−eqString :: (Text, Text)

311+eqString :: forall a b. (IsString a, IsString b) => (a, b)

296eqString = (C.dataEq, C.eqString)

312eqString = (C.dataEq, C.eqString)

297

313

298−eqChar :: (Text, Text)

314+eqChar :: forall a b. (IsString a, IsString b) => (a, b)

299eqChar = (C.dataEq, C.eqChar)

315eqChar = (C.dataEq, C.eqChar)

300

316

301−eqBoolean :: (Text, Text)

317+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)

302eqBoolean = (C.dataEq, C.eqBoolean)

318eqBoolean = (C.dataEq, C.eqBoolean)

303

319

304−ordBoolean :: (Text, Text)

320+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)

305ordBoolean = (C.dataOrd, C.ordBoolean)

321ordBoolean = (C.dataOrd, C.ordBoolean)

306

322

307−ordNumber :: (Text, Text)

323+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)

308ordNumber = (C.dataOrd, C.ordNumber)

324ordNumber = (C.dataOrd, C.ordNumber)

309

325

310−ordInt :: (Text, Text)

326+ordInt :: forall a b. (IsString a, IsString b) => (a, b)

311ordInt = (C.dataOrd, C.ordInt)

327ordInt = (C.dataOrd, C.ordInt)

312

328

313−ordString :: (Text, Text)

329+ordString :: forall a b. (IsString a, IsString b) => (a, b)

314ordString = (C.dataOrd, C.ordString)

330ordString = (C.dataOrd, C.ordString)

315

331

316−ordChar :: (Text, Text)

332+ordChar :: forall a b. (IsString a, IsString b) => (a, b)

317ordChar = (C.dataOrd, C.ordChar)

333ordChar = (C.dataOrd, C.ordChar)

318

334

319−semigroupString :: (Text, Text)

335+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)

320semigroupString = (C.dataSemigroup, C.semigroupString)

336semigroupString = (C.dataSemigroup, C.semigroupString)

321

337

322−boundedBoolean :: (Text, Text)

338+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)

323boundedBoolean = (C.dataBounded, C.boundedBoolean)

339boundedBoolean = (C.dataBounded, C.boundedBoolean)

324

340

325−heytingAlgebraBoolean :: (Text, Text)

341+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)

326heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

342heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

327

343

328−semigroupoidFn :: (Text, Text)

344+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)

329semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

345semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

330

346

331−opAdd :: (Text, Text)

347+opAdd :: forall a b. (IsString a, IsString b) => (a, b)

332opAdd = (C.dataSemiring, C.add)

348opAdd = (C.dataSemiring, C.add)

333

349

334−opMul :: (Text, Text)

350+opMul :: forall a b. (IsString a, IsString b) => (a, b)

335opMul = (C.dataSemiring, C.mul)

351opMul = (C.dataSemiring, C.mul)

336

352

337−opEq :: (Text, Text)

353+opEq :: forall a b. (IsString a, IsString b) => (a, b)

338opEq = (C.dataEq, C.eq)

354opEq = (C.dataEq, C.eq)

339

355

340−opNotEq :: (Text, Text)

356+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)

341opNotEq = (C.dataEq, C.notEq)

357opNotEq = (C.dataEq, C.notEq)

342

358

343−opLessThan :: (Text, Text)

359+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)

344opLessThan = (C.dataOrd, C.lessThan)

360opLessThan = (C.dataOrd, C.lessThan)

345

361

346−opLessThanOrEq :: (Text, Text)

362+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

347opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

363opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

348

364

349−opGreaterThan :: (Text, Text)

365+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)

350opGreaterThan = (C.dataOrd, C.greaterThan)

366opGreaterThan = (C.dataOrd, C.greaterThan)

351

367

352−opGreaterThanOrEq :: (Text, Text)

368+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

353opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

369opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

354

370

355−opAppend :: (Text, Text)

371+opAppend :: forall a b. (IsString a, IsString b) => (a, b)

356opAppend = (C.dataSemigroup, C.append)

372opAppend = (C.dataSemigroup, C.append)

357

373

358−opSub :: (Text, Text)

374+opSub :: forall a b. (IsString a, IsString b) => (a, b)

359opSub = (C.dataRing, C.sub)

375opSub = (C.dataRing, C.sub)

360

376

361−opNegate :: (Text, Text)

377+opNegate :: forall a b. (IsString a, IsString b) => (a, b)

362opNegate = (C.dataRing, C.negate)

378opNegate = (C.dataRing, C.negate)

363

379

364−opDiv :: (Text, Text)

380+opDiv :: forall a b. (IsString a, IsString b) => (a, b)

365opDiv = (C.dataEuclideanRing, C.div)

381opDiv = (C.dataEuclideanRing, C.div)

366

382

367−opMod :: (Text, Text)

383+opMod :: forall a b. (IsString a, IsString b) => (a, b)

368opMod = (C.dataEuclideanRing, C.mod)

384opMod = (C.dataEuclideanRing, C.mod)

369

385

370−opConj :: (Text, Text)

386+opConj :: forall a b. (IsString a, IsString b) => (a, b)

371opConj = (C.dataHeytingAlgebra, C.conj)

387opConj = (C.dataHeytingAlgebra, C.conj)

372

388

373−opDisj :: (Text, Text)

389+opDisj :: forall a b. (IsString a, IsString b) => (a, b)

374opDisj = (C.dataHeytingAlgebra, C.disj)

390opDisj = (C.dataHeytingAlgebra, C.disj)

375

391

376−opNot :: (Text, Text)

392+opNot :: forall a b. (IsString a, IsString b) => (a, b)

377opNot = (C.dataHeytingAlgebra, C.not)

393opNot = (C.dataHeytingAlgebra, C.not)

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

@@ -64,11 +64,11 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

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

65 isPure _ = False

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

67− isBindPoly = isFn (C.controlBind, C.bind)

67+ isBindPoly = isDict (C.controlBind, C.bind)

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

69− isPurePoly = isFn (C.controlApplicative, C.pure')

69+ isPurePoly = isDict (C.controlApplicative, C.pure')

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

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

71+ isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name'

72 isEffFunc _ _ = False

73

74 -- Remove __do function applications which remain after desugaring

@@ -107,14 +107,14 @@ inlineST = everywhereOnJS convertBlock

107 convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =

108 JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])

109 convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =

110− if agg then ref else JSAccessor s1 C.stRefValue ref

110+ if agg then ref else JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref

111 convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

112− if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg

112+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) arg

113 convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

114− if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])

114+ if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref])

115 convert _ other = other

116 -- Check if an expression represents a function in the ST module

117− isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'

117+ isSTFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name'

118 isSTFunc _ _ = False

119 -- Find all ST Refs initialized in this block

120 findSTRefsIn = everythingOnJS (++) isSTRef

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+11−12

@@ -80,7 +80,17 @@ tco' = everywhereOnJS convert

80 countSelfCallsUnderFunctions _ = 0

81

82 countSelfCallsWithFnArgs :: JS -> Int

83− countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

83+ countSelfCallsWithFnArgs = go [] where

84+ go acc (JSVar _ ident')

85+ | ident == ident' && any hasFunction acc = 1

86+ go acc (JSApp _ fn args) = go (args ++ acc) fn

87+ go _ _ = 0

88+

89+ hasFunction :: JS -> Bool

90+ hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

91+ where

92+ isFunction JSFunction{} = True

93+ isFunction _ = False

84

94

85 toLoop :: Text -> [Text] -> JS -> JS

95 toLoop :: Text -> [Text] -> JS -> JS

86 toLoop ident allArgs js = JSBlock rootSS $

96 toLoop ident allArgs js = JSBlock rootSS $

@@ -108,14 +118,3 @@ tco' = everywhereOnJS convert

108 isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

118 isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

109 isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

119 isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

110 isSelfCall _ _ = False

120 isSelfCall _ _ = False

111−

112− isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool

113− isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

114− isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

115− isSelfCallWithFnArgs _ _ _ = False

116−

117− hasFunction :: JS -> Bool

118− hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

119− where

120− isFunction JSFunction{} = True

121− isFunction _ = False

src/Language/PureScript/Constants.hs+136−127

@@ -2,319 +2,319 @@

2module Language.PureScript.Constants where

3

4import Prelude.Compat

5−import Data.Text (Text)

5+import Data.String (IsString)

6import Language.PureScript.Names

7

8-- Operators

9

10−($) :: Text

10+($) :: forall a. (IsString a) => a

11($) = "$"

12

13−apply :: Text

13+apply :: forall a. (IsString a) => a

14apply = "apply"

15

16−(#) :: Text

16+(#) :: forall a. (IsString a) => a

17(#) = "#"

18

19−applyFlipped :: Text

19+applyFlipped :: forall a. (IsString a) => a

20applyFlipped = "applyFlipped"

21

22−(<>) :: Text

22+(<>) :: forall a. (IsString a) => a

23(<>) = "<>"

24

25−(++) :: Text

25+(++) :: forall a. (IsString a) => a

26(++) = "++"

27

28−append :: Text

28+append :: forall a. (IsString a) => a

29append = "append"

30

31−(>>=) :: Text

31+(>>=) :: forall a. (IsString a) => a

32(>>=) = ">>="

33

34−bind :: Text

34+bind :: forall a. (IsString a) => a

35bind = "bind"

36

37−(+) :: Text

37+(+) :: forall a. (IsString a) => a

38(+) = "+"

39

40−add :: Text

40+add :: forall a. (IsString a) => a

41add = "add"

42

43−(-) :: Text

43+(-) :: forall a. (IsString a) => a

44(-) = "-"

45

46−sub :: Text

46+sub :: forall a. (IsString a) => a

47sub = "sub"

48

49−(*) :: Text

49+(*) :: forall a. (IsString a) => a

50(*) = "*"

51

52−mul :: Text

52+mul :: forall a. (IsString a) => a

53mul = "mul"

54

55−(/) :: Text

55+(/) :: forall a. (IsString a) => a

56(/) = "/"

57

58−div :: Text

58+div :: forall a. (IsString a) => a

59div = "div"

60

61−(%) :: Text

61+(%) :: forall a. (IsString a) => a

62(%) = "%"

63

64−mod :: Text

64+mod :: forall a. (IsString a) => a

65mod = "mod"

66

67−(<) :: Text

67+(<) :: forall a. (IsString a) => a

68(<) = "<"

69

70−lessThan :: Text

70+lessThan :: forall a. (IsString a) => a

71lessThan = "lessThan"

72

73−(>) :: Text

73+(>) :: forall a. (IsString a) => a

74(>) = ">"

75

76−greaterThan :: Text

76+greaterThan :: forall a. (IsString a) => a

77greaterThan = "greaterThan"

78

79−(<=) :: Text

79+(<=) :: forall a. (IsString a) => a

80(<=) = "<="

81

82−lessThanOrEq :: Text

82+lessThanOrEq :: forall a. (IsString a) => a

83lessThanOrEq = "lessThanOrEq"

84

85−(>=) :: Text

85+(>=) :: forall a. (IsString a) => a

86(>=) = ">="

87

88−greaterThanOrEq :: Text

88+greaterThanOrEq :: forall a. (IsString a) => a

89greaterThanOrEq = "greaterThanOrEq"

90

91−(==) :: Text

91+(==) :: forall a. (IsString a) => a

92(==) = "=="

93

94−eq :: Text

94+eq :: forall a. (IsString a) => a

95eq = "eq"

96

97−(/=) :: Text

97+(/=) :: forall a. (IsString a) => a

98(/=) = "/="

99

100−notEq :: Text

100+notEq :: forall a. (IsString a) => a

101notEq = "notEq"

102

103−compare :: Text

103+compare :: forall a. (IsString a) => a

104compare = "compare"

105

106−(&&) :: Text

106+(&&) :: forall a. (IsString a) => a

107(&&) = "&&"

108

109−conj :: Text

109+conj :: forall a. (IsString a) => a

110conj = "conj"

111

112−(||) :: Text

112+(||) :: forall a. (IsString a) => a

113(||) = "||"

114

115−disj :: Text

115+disj :: forall a. (IsString a) => a

116disj = "disj"

117

118−unsafeIndex :: Text

118+unsafeIndex :: forall a. (IsString a) => a

119unsafeIndex = "unsafeIndex"

120

121−or :: Text

121+or :: forall a. (IsString a) => a

122or = "or"

123

124−and :: Text

124+and :: forall a. (IsString a) => a

125and = "and"

126

127−xor :: Text

127+xor :: forall a. (IsString a) => a

128xor = "xor"

129

130−(<<<) :: Text

130+(<<<) :: forall a. (IsString a) => a

131(<<<) = "<<<"

132

133−compose :: Text

133+compose :: forall a. (IsString a) => a

134compose = "compose"

135

136−(>>>) :: Text

136+(>>>) :: forall a. (IsString a) => a

137(>>>) = ">>>"

138

139−composeFlipped :: Text

139+composeFlipped :: forall a. (IsString a) => a

140composeFlipped = "composeFlipped"

141

142−map :: Text

142+map :: forall a. (IsString a) => a

143map = "map"

144

145-- Functions

146

147−negate :: Text

147+negate :: forall a. (IsString a) => a

148negate = "negate"

149

150−not :: Text

150+not :: forall a. (IsString a) => a

151not = "not"

152

153−shl :: Text

153+shl :: forall a. (IsString a) => a

154shl = "shl"

155

156−shr :: Text

156+shr :: forall a. (IsString a) => a

157shr = "shr"

158

159−zshr :: Text

159+zshr :: forall a. (IsString a) => a

160zshr = "zshr"

161

162−complement :: Text

162+complement :: forall a. (IsString a) => a

163complement = "complement"

164

165-- Prelude Values

166

167−zero :: Text

167+zero :: forall a. (IsString a) => a

168zero = "zero"

169

170−one :: Text

170+one :: forall a. (IsString a) => a

171one = "one"

172

173−bottom :: Text

173+bottom :: forall a. (IsString a) => a

174bottom = "bottom"

175

176−top :: Text

176+top :: forall a. (IsString a) => a

177top = "top"

178

179−return :: Text

179+return :: forall a. (IsString a) => a

180return = "return"

181

182−pure' :: Text

182+pure' :: forall a. (IsString a) => a

183pure' = "pure"

184

185−returnEscaped :: Text

185+returnEscaped :: forall a. (IsString a) => a

186returnEscaped = "$return"

187

188−untilE :: Text

188+untilE :: forall a. (IsString a) => a

189untilE = "untilE"

190

191−whileE :: Text

191+whileE :: forall a. (IsString a) => a

192whileE = "whileE"

193

194−runST :: Text

194+runST :: forall a. (IsString a) => a

195runST = "runST"

196

197−stRefValue :: Text

197+stRefValue :: forall a. (IsString a) => a

198stRefValue = "value"

199

200−newSTRef :: Text

200+newSTRef :: forall a. (IsString a) => a

201newSTRef = "newSTRef"

202

203−readSTRef :: Text

203+readSTRef :: forall a. (IsString a) => a

204readSTRef = "readSTRef"

205

206−writeSTRef :: Text

206+writeSTRef :: forall a. (IsString a) => a

207writeSTRef = "writeSTRef"

208

209−modifySTRef :: Text

209+modifySTRef :: forall a. (IsString a) => a

210modifySTRef = "modifySTRef"

211

212−mkFn :: Text

212+mkFn :: forall a. (IsString a) => a

213mkFn = "mkFn"

214

215−runFn :: Text

215+runFn :: forall a. (IsString a) => a

216runFn = "runFn"

217

218−unit :: Text

218+unit :: forall a. (IsString a) => a

219unit = "unit"

220

221-- Prim values

222

223−undefined :: Text

223+undefined :: forall a. (IsString a) => a

224undefined = "undefined"

225

226-- Type Class Dictionary Names

227

228−monadEffDictionary :: Text

228+monadEffDictionary :: forall a. (IsString a) => a

229monadEffDictionary = "monadEff"

230

231−applicativeEffDictionary :: Text

231+applicativeEffDictionary :: forall a. (IsString a) => a

232applicativeEffDictionary = "applicativeEff"

233

234−bindEffDictionary :: Text

234+bindEffDictionary :: forall a. (IsString a) => a

235bindEffDictionary = "bindEff"

236

237−semiringNumber :: Text

237+semiringNumber :: forall a. (IsString a) => a

238semiringNumber = "semiringNumber"

239

240−semiringInt :: Text

240+semiringInt :: forall a. (IsString a) => a

241semiringInt = "semiringInt"

242

243−ringNumber :: Text

243+ringNumber :: forall a. (IsString a) => a

244ringNumber = "ringNumber"

245

246−ringInt :: Text

246+ringInt :: forall a. (IsString a) => a

247ringInt = "ringInt"

248

249−moduloSemiringNumber :: Text

249+moduloSemiringNumber :: forall a. (IsString a) => a

250moduloSemiringNumber = "moduloSemiringNumber"

251

252−moduloSemiringInt :: Text

252+moduloSemiringInt :: forall a. (IsString a) => a

253moduloSemiringInt = "moduloSemiringInt"

254

255−euclideanRingNumber :: Text

255+euclideanRingNumber :: forall a. (IsString a) => a

256euclideanRingNumber = "euclideanRingNumber"

257

258−euclideanRingInt :: Text

258+euclideanRingInt :: forall a. (IsString a) => a

259euclideanRingInt = "euclideanRingInt"

260

261−ordBoolean :: Text

261+ordBoolean :: forall a. (IsString a) => a

262ordBoolean = "ordBoolean"

263

264−ordNumber :: Text

264+ordNumber :: forall a. (IsString a) => a

265ordNumber = "ordNumber"

266

267−ordInt :: Text

267+ordInt :: forall a. (IsString a) => a

268ordInt = "ordInt"

269

270−ordString :: Text

270+ordString :: forall a. (IsString a) => a

271ordString = "ordString"

272

273−ordChar :: Text

273+ordChar :: forall a. (IsString a) => a

274ordChar = "ordChar"

275

276−eqNumber :: Text

276+eqNumber :: forall a. (IsString a) => a

277eqNumber = "eqNumber"

278

279−eqInt :: Text

279+eqInt :: forall a. (IsString a) => a

280eqInt = "eqInt"

281

282−eqString :: Text

282+eqString :: forall a. (IsString a) => a

283eqString = "eqString"

284

285−eqChar :: Text

285+eqChar :: forall a. (IsString a) => a

286eqChar = "eqChar"

287

288−eqBoolean :: Text

288+eqBoolean :: forall a. (IsString a) => a

289eqBoolean = "eqBoolean"

290

291−boundedBoolean :: Text

291+boundedBoolean :: forall a. (IsString a) => a

292boundedBoolean = "boundedBoolean"

293

294−booleanAlgebraBoolean :: Text

294+booleanAlgebraBoolean :: forall a. (IsString a) => a

295booleanAlgebraBoolean = "booleanAlgebraBoolean"

296

297−heytingAlgebraBoolean :: Text

297+heytingAlgebraBoolean :: forall a. (IsString a) => a

298heytingAlgebraBoolean = "heytingAlgebraBoolean"

299

300−semigroupString :: Text

300+semigroupString :: forall a. (IsString a) => a

301semigroupString = "semigroupString"

302

303−semigroupoidFn :: Text

303+semigroupoidFn :: forall a. (IsString a) => a

304semigroupoidFn = "semigroupoidFn"

305

306-- Generic Deriving

307

308−generic :: Text

308+generic :: forall a. (IsString a) => a

309generic = "Generic"

310

311−toSpine :: Text

311+toSpine :: forall a. (IsString a) => a

312toSpine = "toSpine"

313

314−fromSpine :: Text

314+fromSpine :: forall a. (IsString a) => a

315fromSpine = "fromSpine"

316

317−toSignature :: Text

317+toSignature :: forall a. (IsString a) => a

318toSignature = "toSignature"

319

320-- Data.Symbol

@@ -352,12 +352,12 @@ orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT")

352

353-- Main module

354

355−main :: Text

355+main :: forall a. (IsString a) => a

356main = "main"

357

358-- Prim

359

360−partial :: Text

360+partial :: forall a. (IsString a) => a

361partial = "Partial"

362

363pattern Prim :: ModuleName

@@ -369,78 +369,87 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial")

369pattern Fail :: Qualified (ProperName 'ClassName)

370pattern Fail = Qualified (Just Prim) (ProperName "Fail")

371

372−typ :: Text

372+pattern Warn :: Qualified (ProperName 'ClassName)

373+pattern Warn = Qualified (Just Prim) (ProperName "Warn")

374+

375+typ :: forall a. (IsString a) => a

373typ = "Type"

376typ = "Type"

374

377

375−effect :: Text

378+effect :: forall a. (IsString a) => a

376effect = "Effect"

379effect = "Effect"

377

380

378−symbol :: Text

381+symbol :: forall a. (IsString a) => a

379symbol = "Symbol"

382symbol = "Symbol"

380

383

381-- Code Generation

384-- Code Generation

382

385

383−__superclass_ :: Text

386+__superclass_ :: forall a. (IsString a) => a

384__superclass_ = "__superclass_"

387__superclass_ = "__superclass_"

385

388

386−__unused :: Text

389+__unused :: forall a. (IsString a) => a

387__unused = "__unused"

390__unused = "__unused"

388

391

389-- Modules

392-- Modules

390

393

391−prim :: Text

394+prim :: forall a. (IsString a) => a

392prim = "Prim"

395prim = "Prim"

393

396

394−prelude :: Text

397+prelude :: forall a. (IsString a) => a

395prelude = "Prelude"

398prelude = "Prelude"

396

399

397−dataArray :: Text

400+dataArray :: forall a. (IsString a) => a

398dataArray = "Data_Array"

401dataArray = "Data_Array"

399

402

400−eff :: Text

403+eff :: forall a. (IsString a) => a

401eff = "Control_Monad_Eff"

404eff = "Control_Monad_Eff"

402

405

403−st :: Text

406+st :: forall a. (IsString a) => a

404st = "Control_Monad_ST"

407st = "Control_Monad_ST"

405

408

406−controlApplicative :: Text

409+controlApplicative :: forall a. (IsString a) => a

407controlApplicative = "Control_Applicative"

410controlApplicative = "Control_Applicative"

408

411

409−controlSemigroupoid :: Text

412+controlSemigroupoid :: forall a. (IsString a) => a

410controlSemigroupoid = "Control_Semigroupoid"

413controlSemigroupoid = "Control_Semigroupoid"

411

414

412−controlBind :: Text

415+controlBind :: forall a. (IsString a) => a

413controlBind = "Control_Bind"

416controlBind = "Control_Bind"

414

417

415−dataBounded :: Text

418+dataBounded :: forall a. (IsString a) => a

416dataBounded = "Data_Bounded"

419dataBounded = "Data_Bounded"

417

420

418−dataSemigroup :: Text

421+dataSemigroup :: forall a. (IsString a) => a

419dataSemigroup = "Data_Semigroup"

422dataSemigroup = "Data_Semigroup"

420

423

421−dataHeytingAlgebra :: Text

424+dataHeytingAlgebra :: forall a. (IsString a) => a

422dataHeytingAlgebra = "Data_HeytingAlgebra"

425dataHeytingAlgebra = "Data_HeytingAlgebra"

423

426

424−dataEq :: Text

427+dataEq :: forall a. (IsString a) => a

425dataEq = "Data_Eq"

428dataEq = "Data_Eq"

426

429

427−dataOrd :: Text

430+dataOrd :: forall a. (IsString a) => a

428dataOrd = "Data_Ord"

431dataOrd = "Data_Ord"

429

432

430−dataSemiring :: Text

433+dataSemiring :: forall a. (IsString a) => a

431dataSemiring = "Data_Semiring"

434dataSemiring = "Data_Semiring"

432

435

433−dataRing :: Text

436+dataRing :: forall a. (IsString a) => a

434dataRing = "Data_Ring"

437dataRing = "Data_Ring"

435

438

436−dataEuclideanRing :: Text

439+dataEuclideanRing :: forall a. (IsString a) => a

437dataEuclideanRing = "Data_EuclideanRing"

440dataEuclideanRing = "Data_EuclideanRing"

438

441

439−dataFunction :: Text

442+dataFunction :: forall a. (IsString a) => a

440dataFunction = "Data_Function"

443dataFunction = "Data_Function"

441

444

442−dataFunctionUncurried :: Text

445+dataFunctionUncurried :: forall a. (IsString a) => a

443dataFunctionUncurried = "Data_Function_Uncurried"

446dataFunctionUncurried = "Data_Function_Uncurried"

444

447

445−dataIntBits :: Text

448+dataIntBits :: forall a. (IsString a) => a

446dataIntBits = "Data_Int_Bits"

449dataIntBits = "Data_Int_Bits"

450+

451+partialUnsafe :: forall a. (IsString a) => a

452+partialUnsafe = "Partial_Unsafe"

453+

454+unsafePartial :: forall a. (IsString a) => a

455+unsafePartial = "unsafePartial"

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

@@ -8,8 +8,7 @@ module Language.PureScript.Docs (

8

9import Language.PureScript.Docs.Convert as Docs

10import Language.PureScript.Docs.Prim as Docs

11−import Language.PureScript.Docs.ParseAndBookmark as Docs

11+import Language.PureScript.Docs.ParseInPackage as Docs

12import Language.PureScript.Docs.Render as Docs

13−import Language.PureScript.Docs.RenderedCode.Render as Docs

13+import Language.PureScript.Docs.RenderedCode as Docs

14−import Language.PureScript.Docs.RenderedCode.Types as Docs

15import Language.PureScript.Docs.Types as Docs

14import Language.PureScript.Docs.Types as Docs

src/Language/PureScript/Docs/AsMarkdown.hs+4−6

@@ -77,12 +77,10 @@ declAsMarkdown mn decl@Declaration{..} = do

77codeToString :: RenderedCode -> Text

78codeToString = outputWith elemAsMarkdown

79 where

80− elemAsMarkdown (Syntax x) = x

80+ elemAsMarkdown (Syntax x) = x

81− elemAsMarkdown (Ident x _) = x

82− elemAsMarkdown (Ctor x _) = x

83− elemAsMarkdown (Kind x) = x

84− elemAsMarkdown (Keyword x) = x

81+ elemAsMarkdown (Keyword x) = x

85− elemAsMarkdown Space = " "

82+ elemAsMarkdown Space = " "

83+ elemAsMarkdown (Symbol _ x _) = x

86

84

87-- fixityAsMarkdown :: P.Fixity -> Docs

85-- fixityAsMarkdown :: P.Fixity -> Docs

88-- fixityAsMarkdown (P.Fixity associativity precedence) =

86-- fixityAsMarkdown (P.Fixity associativity precedence) =

src/Language/PureScript/Docs/Convert.hs+42−30

@@ -3,28 +3,27 @@

3

4module Language.PureScript.Docs.Convert

5 ( convertModules

6+ , convertModulesWithEnv

6 , convertModulesInPackage

7 , convertModulesInPackage

7− , collectBookmarks

8+ , convertModulesInPackageWithEnv

8 ) where

9 ) where

9

10

10−import Prelude.Compat

11+import Protolude hiding (check)

11

12

12−import Control.Arrow ((&&&), second)

13+import Control.Arrow ((&&&))

13import Control.Category ((>>>))

14import Control.Category ((>>>))

14−import Control.Monad

15−import Control.Monad.Error.Class (MonadError)

16−import Control.Monad.State (runStateT)

17import Control.Monad.Writer.Strict (runWriterT)

15import Control.Monad.Writer.Strict (runWriterT)

18−import Data.List (find)

19import qualified Data.Map as Map

16import qualified Data.Map as Map

20−import Data.Text (Text)

17+import Data.String (String)

21

18

22import Language.PureScript.Docs.Convert.ReExports (updateReExports)

19import Language.PureScript.Docs.Convert.ReExports (updateReExports)

23−import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

20+import Language.PureScript.Docs.Convert.Single (convertSingleModule)

24import Language.PureScript.Docs.Types

21import Language.PureScript.Docs.Types

25import qualified Language.PureScript as P

22import qualified Language.PureScript as P

26import qualified Language.PureScript.Constants as C

23import qualified Language.PureScript.Constants as C

27

24

25+import Web.Bower.PackageMeta (PackageName)

26+

28import Text.Parsec (eof)

27import Text.Parsec (eof)

29

28

30-- |

29-- |

@@ -34,32 +33,36 @@ import Text.Parsec (eof)

34--

33--

35convertModulesInPackage ::

34convertModulesInPackage ::

36 (MonadError P.MultipleErrors m) =>

35 (MonadError P.MultipleErrors m) =>

37− [InPackage P.Module] ->

36+ [P.Module] ->

37+ Map P.ModuleName PackageName ->

38 m [Module]

39−convertModulesInPackage modules =

39+convertModulesInPackage modules modulesDeps =

40+ fmap fst (convertModulesInPackageWithEnv modules modulesDeps)

41+

42+convertModulesInPackageWithEnv ::

43+ (MonadError P.MultipleErrors m) =>

44+ [P.Module] ->

45+ Map P.ModuleName PackageName ->

46+ m ([Module], P.Env)

47+convertModulesInPackageWithEnv modules modulesDeps =

40 go modules

48 go modules

41 where

49 where

42− localNames =

43− map P.getModuleName (takeLocals modules)

44 go =

50 go =

45− map ignorePackage

51+ convertModulesWithEnv withPackage

46− >>> convertModules withPackage

47− >>> fmap (filter ((`elem` localNames) . modName))

52+ >>> fmap (first (filter (isLocal . modName)))

48

53

49 withPackage :: P.ModuleName -> InPackage P.ModuleName

54 withPackage :: P.ModuleName -> InPackage P.ModuleName

50 withPackage mn =

55 withPackage mn =

51− case find ((== mn) . P.getModuleName . ignorePackage) modules of

56+ case Map.lookup mn modulesDeps of

52− Just m ->

57+ Just pkgName -> FromDep pkgName mn

53− fmap P.getModuleName m

54− Nothing ->

58+ Nothing -> Local mn

55− P.internalError $ "withPackage: missing module:" ++

59+

56− show (P.runModuleName mn)

60+ isLocal :: P.ModuleName -> Bool

61+ isLocal = not . flip Map.member modulesDeps

57

62

58-- |

63-- |

59-- Convert a group of modules to the intermediate format, designed for

64-- Convert a group of modules to the intermediate format, designed for

60−-- producing documentation from. It is also necessary to pass an Env containing

65+-- producing documentation from.

61−-- imports/exports information about the list of modules, which is needed for

62−-- documenting re-exports.

63--

66--

64-- Note that the whole module dependency graph must be included in the list; if

67-- Note that the whole module dependency graph must be included in the list; if

65-- some modules import things from other modules, then those modules must also

68-- some modules import things from other modules, then those modules must also

@@ -75,6 +78,14 @@ convertModules ::

75 [P.Module] ->

78 [P.Module] ->

76 m [Module]

79 m [Module]

77convertModules withPackage =

80convertModules withPackage =

81+ fmap fst . convertModulesWithEnv withPackage

82+

83+convertModulesWithEnv ::

84+ (MonadError P.MultipleErrors m) =>

85+ (P.ModuleName -> InPackage P.ModuleName) ->

86+ [P.Module] ->

87+ m ([Module], P.Env)

88+convertModulesWithEnv withPackage =

78 P.sortModules

89 P.sortModules

79 >>> fmap (fst >>> map importPrim)

90 >>> fmap (fst >>> map importPrim)

80 >=> convertSorted withPackage

91 >=> convertSorted withPackage

@@ -83,21 +94,22 @@ importPrim :: P.Module -> P.Module

83importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

94importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

84

95

85-- |

96-- |

86−-- Convert a sorted list of modules.

97+-- Convert a sorted list of modules, returning both the list of converted

98+-- modules and the Env produced during desugaring.

87--

99--

88convertSorted ::

100convertSorted ::

89 (MonadError P.MultipleErrors m) =>

101 (MonadError P.MultipleErrors m) =>

90 (P.ModuleName -> InPackage P.ModuleName) ->

102 (P.ModuleName -> InPackage P.ModuleName) ->

91 [P.Module] ->

103 [P.Module] ->

92− m [Module]

104+ m ([Module], P.Env)

93convertSorted withPackage modules = do

105convertSorted withPackage modules = do

94 (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules

106 (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules

95

107

96 modulesWithTypes <- typeCheckIfNecessary modules convertedModules

108 modulesWithTypes <- typeCheckIfNecessary modules convertedModules

97− let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)

109+ let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes)

98

110

99 let traversalOrder = map P.getModuleName modules

111 let traversalOrder = map P.getModuleName modules

100− pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap))

112+ pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env)

101

113

102-- |

114-- |

103-- If any exported value declarations have either wildcard type signatures, or

115-- If any exported value declarations have either wildcard type signatures, or

@@ -166,7 +178,7 @@ insertValueTypes env m =

166 other

178 other

167

179

168 parseIdent =

180 parseIdent =

169− either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent

181+ either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent

170

182

171 lookupName name =

183 lookupName name =

172 let key = P.Qualified (Just (modName m)) name

184 let key = P.Qualified (Just (modName m)) name

src/Language/PureScript/Docs/Convert/Single.hs−13

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

1module Language.PureScript.Docs.Convert.Single

2 ( convertSingleModule

3− , collectBookmarks

4 ) where

3 ) where

5

4

6import Protolude

5import Protolude

@@ -184,15 +183,3 @@ convertComments cs = do

184

183

185 dropPrefix prefix str =

184 dropPrefix prefix str =

186 fromMaybe str (T.stripPrefix prefix str)

185 fromMaybe str (T.stripPrefix prefix str)

187−

188−-- | Go through a PureScript module and extract a list of Bookmarks; references

189−-- to data types or values, to be used as a kind of index. These are used for

190−-- generating links in the HTML documentation, for example.

191−collectBookmarks :: InPackage P.Module -> [Bookmark]

192−collectBookmarks (Local m) = map Local (collectBookmarks' m)

193−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

194−

195−collectBookmarks' :: P.Module -> [(P.ModuleName, Text)]

196−collectBookmarks' m =

197− map (P.getModuleName m, )

198− (mapMaybe getDeclarationTitle (P.exportedDeclarations m))

src/Language/PureScript/Docs/ParseAndBookmark.hsdeleted−93

@@ -1,93 +0,0 @@

1−module Language.PureScript.Docs.ParseAndBookmark

2− ( parseAndBookmark

3− ) where

4−

5−import Protolude

6−import Prelude (id)

7−

8−import qualified Data.Map as M

9−

10−import Language.PureScript.Docs.Convert (collectBookmarks)

11−import Language.PureScript.Docs.Types

12−import qualified Language.PureScript as P

13−import System.IO.UTF8 (readUTF8FileT)

14−import Web.Bower.PackageMeta (PackageName)

15−

16−-- |

17−-- Given:

18−--

19−-- * A list of local source files

20−-- * A list of source files from external dependencies, together with their

21−-- package names

22−--

23−-- This function does the following:

24−--

25−-- * Parse all of the input and dependency source files

26−-- * Associate each dependency module with its package name, thereby

27−-- distinguishing these from local modules

28−-- * Collect a list of bookmarks from the whole set of source files

29−-- * Return the parsed modules and the bookmarks

30−parseAndBookmark ::

31− (MonadError P.MultipleErrors m, MonadIO m) =>

32− [FilePath]

33− -> [(PackageName, FilePath)]

34− -> m ([InPackage P.Module], [Bookmark])

35−parseAndBookmark inputFiles depsFiles = do

36− inputFiles' <- traverse (parseAs Local) inputFiles

37− depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

38−

39− addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')

40−

41−parseFiles ::

42− (MonadError P.MultipleErrors m) =>

43− [(FileInfo, Text)]

44− -> m [(FileInfo, P.Module)]

45−parseFiles =

46− throwLeft . P.parseModulesFromFiles fileInfoToString

47−

48−addBookmarks ::

49− [(FileInfo, P.Module)]

50− -> ([InPackage P.Module], [Bookmark])

51−addBookmarks msInfo =

52− let

53− msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

54− msPackages = map (addPackage msDeps . snd) msInfo

55− bookmarks = concatMap collectBookmarks msPackages

56− in

57− (msPackages, bookmarks)

58−

59−throwLeft :: (MonadError l m) => Either l r -> m r

60−throwLeft = either throwError return

61−

62−-- | Specifies whether a PureScript source file is considered as:

63−--

64−-- 1) with the `Local` constructor, a target source file, i.e., we want to see

65−-- its modules in the output

66−-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do

67−-- not want its modules in the output; it is there to enable desugaring, and

68−-- to ensure that links between modules are constructed correctly.

69−type FileInfo = InPackage FilePath

70−

71−fileInfoToString :: FileInfo -> FilePath

72−fileInfoToString (Local fn) = fn

73−fileInfoToString (FromDep _ fn) = fn

74−

75−parseFile :: FilePath -> IO (FilePath, Text)

76−parseFile input' = (,) input' <$> readUTF8FileT input'

77−

78−parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text)

79−parseAs g = fmap (first g) . liftIO . parseFile

80−

81−getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

82−getDepsModuleNames = foldl' go M.empty

83− where

84− go deps p = deps # case p of

85− Local _ -> id

86− FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName

87− (#) = flip ($)

88−

89−addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module

90−addPackage depsModules m =

91− case M.lookup (P.getModuleName m) depsModules of

92− Just pkgName -> FromDep pkgName m

93− Nothing -> Local m

src/Language/PureScript/Docs/ParseInPackage.hsnew file+73

@@ -0,0 +1,73 @@

1+module Language.PureScript.Docs.ParseInPackage

2+ ( parseFilesInPackages

3+ ) where

4+

5+import Protolude

6+

7+import qualified Data.Map as M

8+

9+import Language.PureScript.Docs.Types

10+import qualified Language.PureScript as P

11+import System.IO.UTF8 (readUTF8FileT)

12+import Web.Bower.PackageMeta (PackageName)

13+

14+-- |

15+-- Given:

16+--

17+-- * A list of local source files

18+-- * A list of source files from external dependencies, together with their

19+-- package names

20+--

21+-- This function does the following:

22+--

23+-- * Parse all of the input and dependency source files

24+-- * Associate each dependency module with its package name, thereby

25+-- distinguishing these from local modules

26+-- * Return the parsed modules and a Map mapping module names to package

27+-- names for modules which come from dependencies. If a module does not

28+-- exist in the map, it can safely be assumed to be local.

29+parseFilesInPackages ::

30+ (MonadError P.MultipleErrors m, MonadIO m) =>

31+ [FilePath]

32+ -> [(PackageName, FilePath)]

33+ -> m ([P.Module], Map P.ModuleName PackageName)

34+parseFilesInPackages inputFiles depsFiles = do

35+ inputFiles' <- traverse (readFileAs . Local) inputFiles

36+ depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles

37+

38+ modules <- parse (inputFiles' ++ depsFiles')

39+

40+ let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules)

41+

42+ pure (map snd modules, mnMap)

43+

44+ where

45+ parse ::

46+ (MonadError P.MultipleErrors m) =>

47+ [(FileInfo, Text)]

48+ -> m [(FileInfo, P.Module)]

49+ parse =

50+ throwLeft . P.parseModulesFromFiles fileInfoToString

51+

52+ inPkgToMaybe = \case

53+ Local _ -> Nothing

54+ FromDep pkgName _ -> Just pkgName

55+

56+throwLeft :: (MonadError l m) => Either l r -> m r

57+throwLeft = either throwError return

58+

59+-- | Specifies whether a PureScript source file is considered as:

60+--

61+-- 1) with the `Local` constructor, a target source file, i.e., we want to see

62+-- its modules in the output

63+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do

64+-- not want its modules in the output; it is there to enable desugaring, and

65+-- to ensure that links between modules are constructed correctly.

66+type FileInfo = InPackage FilePath

67+

68+fileInfoToString :: FileInfo -> FilePath

69+fileInfoToString (Local fn) = fn

70+fileInfoToString (FromDep _ fn) = fn

71+

72+readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text)

73+readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)

src/Language/PureScript/Docs/Prim.hs+9

@@ -24,6 +24,7 @@ primDocsModule = Module

24 , boolean

25 , partial

26 , fail

27+ , warn

27 , typeConcat

28 , typeConcat

28 , typeString

29 , typeString

29 , kindType

30 , kindType

@@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines

225 , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

226 , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

226 ]

227 ]

227

228

229+warn :: Declaration

230+warn = primClass "Warn" $ T.unlines

231+ [ "The Warn type class allows a custom compiler warning to be displayed."

232+ , ""

233+ , "For more information, see"

234+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

235+ ]

236+

228typeConcat :: Declaration

237typeConcat :: Declaration

229typeConcat = primType "TypeConcat" $ T.unlines

238typeConcat = primType "TypeConcat" $ T.unlines

230 [ "The TypeConcat type constructor concatenates two Symbols in a custom type"

239 [ "The TypeConcat type constructor concatenates two Symbols in a custom type"

src/Language/PureScript/Docs/Render.hs+17−27

@@ -28,7 +28,7 @@ renderDeclarationWithOptions :: RenderTypeOptions -> Declaration -> RenderedCode

28renderDeclarationWithOptions opts Declaration{..} =

29 mintersperse sp $ case declInfo of

30 ValueDeclaration ty ->

31− [ ident declTitle

31+ [ ident' declTitle

32 , syntax "::"

33 , renderType' ty

34 ]

@@ -70,40 +70,25 @@ renderDeclarationWithOptions opts Declaration{..} =

70 [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]

71 ]

72 where

73− idents = mintersperse sp . map ident

73+ idents = mintersperse sp . map ident'

74

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

75+ AliasDeclaration (P.Fixity associativity precedence) for ->

76 [ keywordFixity associativity

77 , syntax $ T.pack $ show precedence

78− , ident $ renderQualAlias for

78+ , alias for

79− , keyword "as"

79+ , keywordAs

80− , ident $ adjustAliasName alias declTitle

80+ , aliasName for declTitle

81 ]

82

83 ExternKindDeclaration ->

84 [ keywordKind

85− , renderKind (P.NamedKind (notQualified declTitle))

85+ , kind (notQualified declTitle)

86 ]

87

88 where

89 renderType' :: P.Type -> RenderedCode

90 renderType' = renderTypeWithOptions opts

91

92− renderQualAlias :: FixityAlias -> Text

93− renderQualAlias (P.Qualified mn alias)

94− | mn == currentModule opts = renderAlias id alias

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

96−

97− renderAlias

98− :: (forall a. (a -> Text) -> a -> Text)

99− -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))

100− -> Text

101− renderAlias f

102− = either (("type " <>) . f P.runProperName)

103− $ either (f P.runIdent) (f P.runProperName)

104−

105− adjustAliasName _ title = T.tail (T.init title)

106−

107renderChildDeclaration :: ChildDeclaration -> RenderedCode

92renderChildDeclaration :: ChildDeclaration -> RenderedCode

108renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

93renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

109

94

@@ -113,18 +98,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

113 ChildInstance constraints ty ->

98 ChildInstance constraints ty ->

114 maybeToList (renderConstraints constraints) ++ [ renderType' ty ]

99 maybeToList (renderConstraints constraints) ++ [ renderType' ty ]

115 ChildDataConstructor args ->

100 ChildDataConstructor args ->

116− [ renderType' typeApp' ]

101+ [ dataCtor' cdeclTitle ]

117− where

102+ ++ map renderTypeAtom' args

118− typeApp' = foldl P.TypeApp ctor' args

119− ctor' = P.TypeConstructor (notQualified cdeclTitle)

120

103

121 ChildTypeClassMember ty ->

104 ChildTypeClassMember ty ->

122− [ ident cdeclTitle

105+ [ ident' cdeclTitle

123 , syntax "::"

106 , syntax "::"

124 , renderType' ty

107 , renderType' ty

125 ]

108 ]

126 where

109 where

127 renderType' = renderTypeWithOptions opts

110 renderType' = renderTypeWithOptions opts

111+ renderTypeAtom' = renderTypeAtomWithOptions opts

128

112

129renderConstraint :: P.Constraint -> RenderedCode

113renderConstraint :: P.Constraint -> RenderedCode

130renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

114renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

@@ -151,6 +135,12 @@ renderConstraintsWithOptions opts constraints

151notQualified :: Text -> P.Qualified (P.ProperName a)

135notQualified :: Text -> P.Qualified (P.ProperName a)

152notQualified = P.Qualified Nothing . P.ProperName

136notQualified = P.Qualified Nothing . P.ProperName

153

137

138+ident' :: Text -> RenderedCode

139+ident' = ident . P.Qualified Nothing . P.Ident

140+

141+dataCtor' :: Text -> RenderedCode

142+dataCtor' = dataCtor . notQualified

143+

154typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type

144typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type

155typeApp title typeArgs =

145typeApp title typeArgs =

156 foldl P.TypeApp

146 foldl P.TypeApp

src/Language/PureScript/Docs/RenderedCode.hs+9−8

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

1−

1+

2−-- | Data types and functions for representing a simplified form of PureScript

2+-- | Data types and functions for representing a simplified form of PureScript

3−-- code, intended for use in e.g. HTML documentation.

3+-- code, intended for use in e.g. HTML documentation.

4−

4+

5−module Language.PureScript.Docs.RenderedCode (module RenderedCode) where

5+module Language.PureScript.Docs.RenderedCode (module RenderedCode) where

6−

6+

7−import Language.PureScript.Docs.RenderedCode.Types as RenderedCode

7+import Language.PureScript.Docs.RenderedCode.Types as RenderedCode

8−import Language.PureScript.Docs.RenderedCode.Render as RenderedCode

8+import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode

9+import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode

src/Language/PureScript/Docs/RenderedCode/RenderKind.hsnew file+57

@@ -0,0 +1,57 @@

1+-- | Functions for producing RenderedCode values from PureScript Kind values.

2+--

3+module Language.PureScript.Docs.RenderedCode.RenderKind

4+ ( renderKind

5+ ) where

6+

7+-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds.

8+-- Ideally we would unify the two.

9+

10+import Prelude.Compat

11+

12+import Control.Arrow (ArrowPlus(..))

13+import Control.PatternArrows as PA

14+

15+import Data.Monoid ((<>))

16+import Data.Maybe (fromMaybe)

17+import qualified Data.Text as T

18+

19+import Language.PureScript.Crash

20+import Language.PureScript.Kinds

21+

22+import Language.PureScript.Docs.RenderedCode.Types

23+

24+typeLiterals :: Pattern () Kind RenderedCode

25+typeLiterals = mkPattern match

26+ where

27+ match (KUnknown u) =

28+ Just $ typeVar $ T.cons 'k' (T.pack (show u))

29+ match (NamedKind n) =

30+ Just $ kind n

31+ match _ = Nothing

32+

33+matchRow :: Pattern () Kind ((), Kind)

34+matchRow = mkPattern match

35+ where

36+ match (Row k) = Just ((), k)

37+ match _ = Nothing

38+

39+funKind :: Pattern () Kind (Kind, Kind)

40+funKind = mkPattern match

41+ where

42+ match (FunKind arg ret) = Just (arg, ret)

43+ match _ = Nothing

44+

45+-- | Generate RenderedCode value representing a Kind

46+renderKind :: Kind -> RenderedCode

47+renderKind

48+ = fromMaybe (internalError "Incomplete pattern")

49+ . PA.pattern matchKind ()

50+ where

51+ matchKind :: Pattern () Kind RenderedCode

52+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

53+

54+ operators :: OperatorTable () Kind RenderedCode

55+ operators =

56+ OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k]

57+ , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ]

src/Language/PureScript/Docs/RenderedCode/Render.hs → src/Language/PureScript/Docs/RenderedCode/RenderType.hsrenamed+25−32

@@ -1,13 +1,13 @@

1-- | Functions for producing RenderedCode values from PureScript Type values.

2

3−module Language.PureScript.Docs.RenderedCode.Render

3+module Language.PureScript.Docs.RenderedCode.RenderType

4 ( renderType

5 , renderTypeAtom

6 , renderRow

7− , renderKind

8 , RenderTypeOptions(..)

7 , RenderTypeOptions(..)

9 , defaultRenderTypeOptions

8 , defaultRenderTypeOptions

10 , renderTypeWithOptions

9 , renderTypeWithOptions

10+ , renderTypeAtomWithOptions

11 ) where

12

13import Prelude.Compat

@@ -20,39 +20,40 @@ import Control.Arrow ((<+>))

20import Control.PatternArrows as PA

21

22import Language.PureScript.Crash

23−import Language.PureScript.Docs.RenderedCode.Types

24−import Language.PureScript.Docs.Utils.MonoidExtras

25import Language.PureScript.Environment

23import Language.PureScript.Environment

26import Language.PureScript.Kinds

24import Language.PureScript.Kinds

27import Language.PureScript.Names

25import Language.PureScript.Names

28−import Language.PureScript.Pretty.Kinds

29import Language.PureScript.Pretty.Types

26import Language.PureScript.Pretty.Types

30import Language.PureScript.Types

27import Language.PureScript.Types

31import Language.PureScript.Label (Label)

28import Language.PureScript.Label (Label)

32

29

30+import Language.PureScript.Docs.RenderedCode.Types

31+import Language.PureScript.Docs.Utils.MonoidExtras

32+import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)

33+

33typeLiterals :: Pattern () Type RenderedCode

34typeLiterals :: Pattern () Type RenderedCode

34typeLiterals = mkPattern match

35typeLiterals = mkPattern match

35 where

36 where

36 match TypeWildcard{} =

37 match TypeWildcard{} =

37 Just (syntax "_")

38 Just (syntax "_")

38 match (TypeVar var) =

39 match (TypeVar var) =

39− Just (ident var)

40+ Just (typeVar var)

40 match (PrettyPrintObject row) =

41 match (PrettyPrintObject row) =

41 Just $ mintersperse sp

42 Just $ mintersperse sp

42 [ syntax "{"

43 [ syntax "{"

43 , renderRow row

44 , renderRow row

44 , syntax "}"

45 , syntax "}"

45 ]

46 ]

46− match (TypeConstructor (Qualified mn name)) =

47+ match (TypeConstructor n) =

47− Just (ctor (runProperName name) (maybeToContainingModule mn))

48+ Just (typeCtor n)

48 match REmpty =

49 match REmpty =

49 Just (syntax "()")

50 Just (syntax "()")

50 match row@RCons{} =

51 match row@RCons{} =

51 Just (syntax "(" <> renderRow row <> syntax ")")

52 Just (syntax "(" <> renderRow row <> syntax ")")

52 match (BinaryNoParensType op l r) =

53 match (BinaryNoParensType op l r) =

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

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

54− match (TypeOp (Qualified mn op)) =

55+ match (TypeOp n) =

55− Just (ident' (runOpName op) (maybeToContainingModule mn))

56+ Just (typeOp n)

56 match _ =

57 match _ =

57 Nothing

58 Nothing

58

59

@@ -87,7 +88,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel

87renderLabel :: (Label, Type) -> RenderedCode

88renderLabel :: (Label, Type) -> RenderedCode

88renderLabel (label, ty) =

89renderLabel (label, ty) =

89 mintersperse sp

90 mintersperse sp

90− [ syntax $ prettyPrintLabel label

91+ [ typeVar $ prettyPrintLabel label

91 , syntax "::"

92 , syntax "::"

92 , renderType ty

93 , renderType ty

93 ]

94 ]

@@ -139,7 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

139 OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]

140 OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]

140 , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]

141 , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]

141 , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]

142 , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]

142− , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]

143+ , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ]

143 , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]

144 , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]

144 , [ Wrap explicitParens $ \_ ty -> ty ]

145 , [ Wrap explicitParens $ \_ ty -> ty ]

145 ]

146 ]

@@ -154,12 +155,6 @@ insertPlaceholders :: RenderTypeOptions -> Type -> Type

154insertPlaceholders opts =

155insertPlaceholders opts =

155 everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)

156 everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)

156

157

157−dePrim :: Type -> Type

158−dePrim ty@(TypeConstructor (Qualified _ name))

159− | ty == tyBoolean || ty == tyNumber || ty == tyString =

160− TypeConstructor $ Qualified Nothing name

161−dePrim other = other

162−

163convert :: RenderTypeOptions -> Type -> Type

158convert :: RenderTypeOptions -> Type -> Type

164convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

159convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

165convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r

160convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r

@@ -173,28 +168,20 @@ convertForAlls (ForAll i ty _) = go [i] ty

173convertForAlls other = other

168convertForAlls other = other

174

169

175preprocessType :: RenderTypeOptions -> Type -> Type

170preprocessType :: RenderTypeOptions -> Type -> Type

176−preprocessType opts = dePrim . insertPlaceholders opts

171+preprocessType opts = insertPlaceholders opts

172+

177

173

178-- |

174-- |

179−-- Render code representing a Kind

175+-- Render code representing a Type

180--

176--

181−renderKind :: Kind -> RenderedCode

177+renderType :: Type -> RenderedCode

182−renderKind = kind . prettyPrintKind

178+renderType = renderTypeWithOptions defaultRenderTypeOptions

183

179

184-- |

180-- |

185-- Render code representing a Type, as it should appear inside parentheses

181-- Render code representing a Type, as it should appear inside parentheses

186--

182--

187renderTypeAtom :: Type -> RenderedCode

183renderTypeAtom :: Type -> RenderedCode

188−renderTypeAtom

189− = fromMaybe (internalError "Incomplete pattern")

190− . PA.pattern matchTypeAtom ()

191− . preprocessType defaultRenderTypeOptions

192−

193−-- |

194−-- Render code representing a Type

195−--

196−renderType :: Type -> RenderedCode

197−renderType = renderTypeWithOptions defaultRenderTypeOptions

184+renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions

198

185

199data RenderTypeOptions = RenderTypeOptions

186data RenderTypeOptions = RenderTypeOptions

200 { prettyPrintObjects :: Bool

187 { prettyPrintObjects :: Bool

@@ -213,3 +200,9 @@ renderTypeWithOptions opts

213 = fromMaybe (internalError "Incomplete pattern")

200 = fromMaybe (internalError "Incomplete pattern")

214 . PA.pattern matchType ()

201 . PA.pattern matchType ()

215 . preprocessType opts

202 . preprocessType opts

203+

204+renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode

205+renderTypeAtomWithOptions opts

206+ = fromMaybe (internalError "Incomplete pattern")

207+ . PA.pattern matchTypeAtom ()

208+ . preprocessType opts

src/Language/PureScript/Docs/RenderedCode/Types.hs+251−74

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE DeriveGeneric #-}

2

3

3-- | Data types and functions for representing a simplified form of PureScript

4-- | Data types and functions for representing a simplified form of PureScript

4-- code, intended for use in e.g. HTML documentation.

5-- code, intended for use in e.g. HTML documentation.

@@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types

11 , containingModuleToMaybe

12 , containingModuleToMaybe

12 , maybeToContainingModule

13 , maybeToContainingModule

13 , fromContainingModule

14 , fromContainingModule

15+ , fromQualified

16+ , Namespace(..)

17+ , Link(..)

18+ , FixityAlias

14 , RenderedCode

19 , RenderedCode

15 , asRenderedCode

20 , asRenderedCode

16 , outputWith

21 , outputWith

17 , sp

22 , sp

23+ , parens

18 , syntax

24 , syntax

19− , ident

20− , ident'

21− , ctor

22− , kind

23 , keyword

25 , keyword

24 , keywordForall

26 , keywordForall

25 , keywordData

27 , keywordData

@@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types

30 , keywordWhere

32 , keywordWhere

31 , keywordFixity

33 , keywordFixity

32 , keywordKind

34 , keywordKind

35+ , keywordAs

36+ , ident

37+ , dataCtor

38+ , typeCtor

39+ , typeOp

40+ , typeVar

41+ , kind

42+ , alias

43+ , aliasName

33 ) where

44 ) where

34

45

35import Prelude.Compat

46import Prelude.Compat

47+import GHC.Generics (Generic)

36

48

49+import Control.DeepSeq (NFData)

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

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

38

51

52+import Data.Monoid ((<>))

39import Data.Aeson.BetterErrors

53import Data.Aeson.BetterErrors

40import qualified Data.Aeson as A

54import qualified Data.Aeson as A

41import Data.Text (Text)

55import Data.Text (Text)

56+import qualified Data.Text as T

57+import qualified Data.ByteString.Lazy as BS

58+import qualified Data.Text.Encoding as TE

42

59

60+import Language.PureScript.Names

43−import qualified Language.PureScript as P

61+import Language.PureScript.AST (Associativity(..))

62+import Language.PureScript.Crash (internalError)

44

63

45−-- |

64+-- | Given a list of actions, attempt them all, returning the first success.

46−-- A single element in a rendered code fragment. The intention is to support

65+-- If all the actions fail, 'tryAll' returns the first argument.

47−-- multiple output formats. For example, plain text, or highlighted HTML.

66+tryAll :: MonadError e m => m a -> [m a] -> m a

48−--

67+tryAll = foldr $ \x y -> catchError x (const y)

49−data RenderedCodeElement

50− = Syntax Text

51− | Ident Text ContainingModule

52− | Ctor Text ContainingModule

53− | Kind Text

54− | Keyword Text

55− | Space

56− deriving (Show, Eq, Ord)

57

68

58−instance A.ToJSON RenderedCodeElement where

69+firstEq :: Text -> Parse Text a -> Parse Text a

59− toJSON (Syntax str) =

70+firstEq str p = nth 0 (withText (eq str)) *> p

60− A.toJSON ["syntax", str]

61− toJSON (Ident str mn) =

62− A.toJSON ["ident", A.toJSON str, A.toJSON mn]

63− toJSON (Ctor str mn) =

64− A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]

65− toJSON (Kind str) =

66− A.toJSON ["kind", str]

67− toJSON (Keyword str) =

68− A.toJSON ["keyword", str]

69− toJSON Space =

70− A.toJSON ["space" :: Text]

71−

72−asRenderedCodeElement :: Parse Text RenderedCodeElement

73−asRenderedCodeElement =

74− a Syntax "syntax" <|>

75− asIdent <|>

76− asCtor <|>

77− a Kind "kind" <|>

78− a Keyword "keyword" <|>

79− asSpace <|>

80− unableToParse

81 where

71 where

82− p <|> q = catchError p (const q)

72+ eq s s' = if s == s' then Right () else Left ""

83

73

84− a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)

74+-- |

85− asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)

75+-- Try the given parsers in sequence. If all fail, fail with the given message,

86− asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)

76+-- and include the JSON in the error.

87− asSpace = nth 0 (withText (eq "space")) *> pure Space

77+--

78+tryParse :: Text -> [Parse Text a] -> Parse Text a

79+tryParse msg =

80+ tryAll (withValue (Left . (fullMsg <>) . showJSON))

88

81

89− eq s s' = if s == s' then Right () else Left ""

82+ where

83+ fullMsg = "Invalid " <> msg <> ": "

90

84

91− unableToParse = withText Left

85+ showJSON :: A.Value -> Text

86+ showJSON = TE.decodeUtf8 . BS.toStrict . A.encode

92

87

93-- |

88-- |

94−-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier

89+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit

95−-- to read, as the meaning is more explicit.

90+-- easier to read, as the meaning is more explicit.

96--

91--

97data ContainingModule

92data ContainingModule

98 = ThisModule

93 = ThisModule

99− | OtherModule P.ModuleName

94+ | OtherModule ModuleName

100 deriving (Show, Eq, Ord)

95 deriving (Show, Eq, Ord)

101

96

102instance A.ToJSON ContainingModule where

97instance A.ToJSON ContainingModule where

103− toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)

98+ toJSON = A.toJSON . go

99+ where

100+ go = \case

101+ ThisModule -> ["ThisModule"]

102+ OtherModule mn -> ["OtherModule", runModuleName mn]

104

103

104+instance A.FromJSON ContainingModule where

105+ parseJSON = toAesonParser id asContainingModule

106+

105−asContainingModule :: Parse e ContainingModule

107+asContainingModule :: Parse Text ContainingModule

106asContainingModule =

108asContainingModule =

109+ tryParse "containing module" $

110+ current ++ backwardsCompat

111+ where

112+ current =

113+ [ firstEq "ThisModule" (pure ThisModule)

114+ , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)

115+ ]

116+

117+ -- For JSON produced by compilers up to 0.10.5.

118+ backwardsCompat =

107− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)

119+ [ maybeToContainingModule <$> perhaps asModuleName

120+ ]

121+

122+ asModuleName = moduleNameFromString <$> asText

108

123

109-- |

124-- |

110−-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious

125+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious

111-- isomorphism.

126-- isomorphism.

112--

127--

113−maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule

128+maybeToContainingModule :: Maybe ModuleName -> ContainingModule

114maybeToContainingModule Nothing = ThisModule

129maybeToContainingModule Nothing = ThisModule

115maybeToContainingModule (Just mn) = OtherModule mn

130maybeToContainingModule (Just mn) = OtherModule mn

116

131

117-- |

132-- |

118−-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious

133+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious

119-- isomorphism.

134-- isomorphism.

120--

135--

121−containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName

136+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName

122containingModuleToMaybe ThisModule = Nothing

137containingModuleToMaybe ThisModule = Nothing

123containingModuleToMaybe (OtherModule mn) = Just mn

138containingModuleToMaybe (OtherModule mn) = Just mn

124

139

125-- |

140-- |

126-- A version of 'fromMaybe' for 'ContainingModule' values.

141-- A version of 'fromMaybe' for 'ContainingModule' values.

127--

142--

128−fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName

143+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName

129fromContainingModule def ThisModule = def

144fromContainingModule def ThisModule = def

130fromContainingModule _ (OtherModule mn) = mn

145fromContainingModule _ (OtherModule mn) = mn

131

146

147+fromQualified :: Qualified a -> (ContainingModule, a)

148+fromQualified (Qualified mn x) =

149+ (maybeToContainingModule mn, x)

150+

151+data Link

152+ = NoLink

153+ | Link ContainingModule

154+ deriving (Show, Eq, Ord)

155+

156+instance A.ToJSON Link where

157+ toJSON = \case

158+ NoLink -> A.toJSON ["NoLink" :: Text]

159+ Link mn -> A.toJSON ["Link", A.toJSON mn]

160+

161+asLink :: Parse Text Link

162+asLink =

163+ tryParse "link"

164+ [ firstEq "NoLink" (pure NoLink)

165+ , firstEq "Link" (Link <$> nth 1 asContainingModule)

166+ ]

167+

168+instance A.FromJSON Link where

169+ parseJSON = toAesonParser id asLink

170+

171+data Namespace

172+ = ValueLevel

173+ | TypeLevel

174+ | KindLevel

175+ deriving (Show, Eq, Ord, Generic)

176+

177+instance NFData Namespace

178+

179+instance A.ToJSON Namespace where

180+ toJSON = A.toJSON . show

181+

182+asNamespace :: Parse Text Namespace

183+asNamespace =

184+ tryParse "namespace"

185+ [ withText $ \case

186+ "ValueLevel" -> Right ValueLevel

187+ "TypeLevel" -> Right TypeLevel

188+ "KindLevel" -> Right KindLevel

189+ _ -> Left ""

190+ ]

191+

192+instance A.FromJSON Namespace where

193+ parseJSON = toAesonParser id asNamespace

194+

195+-- |

196+-- A single element in a rendered code fragment. The intention is to support

197+-- multiple output formats. For example, plain text, or highlighted HTML.

198+--

199+data RenderedCodeElement

200+ = Syntax Text

201+ | Keyword Text

202+ | Space

203+ -- | Any symbol which you might or might not want to link to, in any

204+ -- namespace (value, type, or kind). Note that this is not related to the

205+ -- kind called Symbol for type-level strings.

206+ | Symbol Namespace Text Link

207+ deriving (Show, Eq, Ord)

208+

209+instance A.ToJSON RenderedCodeElement where

210+ toJSON (Syntax str) =

211+ A.toJSON ["syntax", str]

212+ toJSON (Keyword str) =

213+ A.toJSON ["keyword", str]

214+ toJSON Space =

215+ A.toJSON ["space" :: Text]

216+ toJSON (Symbol ns str link) =

217+ A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]

218+

219+asRenderedCodeElement :: Parse Text RenderedCodeElement

220+asRenderedCodeElement =

221+ tryParse "RenderedCodeElement" $

222+ [ a Syntax "syntax"

223+ , a Keyword "keyword"

224+ , asSpace

225+ , asSymbol

226+ ] ++ backwardsCompat

227+ where

228+ a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText)

229+ asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink)

230+ asSpace = firstEq "space" (pure Space)

231+

232+ -- These will make some mistakes e.g. treating data constructors as types,

233+ -- because the old code did not save information which is necessary to

234+ -- distinguish these cases. This is the best we can do.

235+ backwardsCompat =

236+ [ oldAsIdent

237+ , oldAsCtor

238+ , oldAsKind

239+ ]

240+

241+ oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))

242+ oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))

243+ oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule))

244+

132-- |

245-- |

133-- A type representing a highly simplified version of PureScript code, intended

246-- A type representing a highly simplified version of PureScript code, intended

134-- for use in output formats like plain text or HTML.

247-- for use in output formats like plain text or HTML.

@@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC

158sp :: RenderedCode

271sp :: RenderedCode

159sp = RC [Space]

272sp = RC [Space]

160

273

274+-- |

275+-- Wrap a RenderedCode value in parens.

276+parens :: RenderedCode -> RenderedCode

277+parens x = syntax "(" <> x <> syntax ")"

278+

279+-- possible TODO: instead of this function, export RenderedCode values for

280+-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,

281+-- syntaxRBrace, etc.

161syntax :: Text -> RenderedCode

282syntax :: Text -> RenderedCode

162syntax x = RC [Syntax x]

283syntax x = RC [Syntax x]

163

284

164−ident :: Text -> RenderedCode

165−ident x = RC [Ident x ThisModule]

166−

167−ident' :: Text -> ContainingModule -> RenderedCode

168−ident' x m = RC [Ident x m]

169−

170−ctor :: Text -> ContainingModule -> RenderedCode

171−ctor x m = RC [Ctor x m]

172−

173−kind :: Text -> RenderedCode

174−kind x = RC [Kind x]

175−

176keyword :: Text -> RenderedCode

285keyword :: Text -> RenderedCode

177keyword kw = RC [Keyword kw]

286keyword kw = RC [Keyword kw]

178

287

@@ -197,10 +306,78 @@ keywordInstance = keyword "instance"

197keywordWhere :: RenderedCode

306keywordWhere :: RenderedCode

198keywordWhere = keyword "where"

307keywordWhere = keyword "where"

199

308

200−keywordFixity :: P.Associativity -> RenderedCode

309+keywordFixity :: Associativity -> RenderedCode

201−keywordFixity P.Infixl = keyword "infixl"

310+keywordFixity Infixl = keyword "infixl"

202−keywordFixity P.Infixr = keyword "infixr"

311+keywordFixity Infixr = keyword "infixr"

203−keywordFixity P.Infix = keyword "infix"

312+keywordFixity Infix = keyword "infix"

204

313

205keywordKind :: RenderedCode

314keywordKind :: RenderedCode

206keywordKind = keyword "kind"

315keywordKind = keyword "kind"

316+

317+keywordAs :: RenderedCode

318+keywordAs = keyword "as"

319+

320+ident :: Qualified Ident -> RenderedCode

321+ident (fromQualified -> (mn, name)) =

322+ RC [Symbol ValueLevel (runIdent name) (Link mn)]

323+

324+dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode

325+dataCtor (fromQualified -> (mn, name)) =

326+ RC [Symbol ValueLevel (runProperName name) (Link mn)]

327+

328+typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode

329+typeCtor (fromQualified -> (mn, name)) =

330+ RC [Symbol TypeLevel (runProperName name) (Link mn)]

331+

332+typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode

333+typeOp (fromQualified -> (mn, name)) =

334+ RC [Symbol TypeLevel (runOpName name) (Link mn)]

335+

336+typeVar :: Text -> RenderedCode

337+typeVar x = RC [Symbol TypeLevel x NoLink]

338+

339+kind :: Qualified (ProperName 'KindName) -> RenderedCode

340+kind (fromQualified -> (mn, name)) =

341+ RC [Symbol KindLevel (runProperName name) (Link mn)]

342+

343+type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))

344+

345+alias :: FixityAlias -> RenderedCode

346+alias for =

347+ prefix <> RC [Symbol ns name (Link mn)]

348+ where

349+ (ns, name, mn) = unpackFixityAlias for

350+ prefix = case ns of

351+ TypeLevel ->

352+ keywordType <> sp

353+ _ ->

354+ mempty

355+

356+aliasName :: FixityAlias -> Text -> RenderedCode

357+aliasName for name' =

358+ let

359+ (ns, _, _) = unpackFixityAlias for

360+ unParen = T.tail . T.init

361+ name = unParen name'

362+ in

363+ case ns of

364+ ValueLevel ->

365+ ident (Qualified Nothing (Ident name))

366+ TypeLevel ->

367+ typeCtor (Qualified Nothing (ProperName name))

368+ KindLevel ->

369+ internalError "Kind aliases are not supported"

370+

371+-- | Converts a FixityAlias into a different representation which is more

372+-- useful to other functions in this module.

373+unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)

374+unpackFixityAlias (fromQualified -> (mn, x)) =

375+ case x of

376+ -- We add some seemingly superfluous type signatures here just to be extra

377+ -- sure we are not mixing up our namespaces.

378+ Left (n :: ProperName 'TypeName) ->

379+ (TypeLevel, runProperName n, mn)

380+ Right (Left n) ->

381+ (ValueLevel, runIdent n, mn)

382+ Right (Right (n :: ProperName 'ConstructorName)) ->

383+ (ValueLevel, runProperName n, mn)

src/Language/PureScript/Docs/Types.hs+80−32

@@ -4,19 +4,14 @@ module Language.PureScript.Docs.Types

4 )

5 where

6

7−import Prelude.Compat

7+import Protolude hiding (to, from)

8+import Prelude (String, unlines)

8

9

9−import Control.Arrow (first, (***))

10+import Control.Arrow ((***))

10−import Control.Monad (when)

11−import Control.Monad.Error.Class (catchError)

12

11

13import Data.Aeson ((.=))

12import Data.Aeson ((.=))

14import Data.Aeson.BetterErrors

13import Data.Aeson.BetterErrors

15−import Data.ByteString.Lazy (ByteString)

14+import qualified Data.Map as Map

16−import Data.Either (isLeft, isRight)

17−import Data.Maybe (mapMaybe, fromMaybe, maybeToList)

18−import Data.Monoid ((<>))

19−import Data.Text (Text)

20import Data.Time.Clock (UTCTime)

15import Data.Time.Clock (UTCTime)

21import qualified Data.Time.Format as TimeFormat

16import qualified Data.Time.Format as TimeFormat

22import Data.Version

17import Data.Version

@@ -33,7 +28,8 @@ import Web.Bower.PackageMeta hiding (Version, displayError)

33import Language.PureScript.Docs.RenderedCode as ReExports

28import Language.PureScript.Docs.RenderedCode as ReExports

34 (RenderedCode, asRenderedCode,

29 (RenderedCode, asRenderedCode,

35 ContainingModule(..), asContainingModule,

30 ContainingModule(..), asContainingModule,

36− RenderedCodeElement(..), asRenderedCodeElement)

31+ RenderedCodeElement(..), asRenderedCodeElement,

32+ Namespace(..), FixityAlias)

37

33

38--------------------

34--------------------

39-- Types

35-- Types

@@ -47,7 +43,7 @@ data Package a = Package

47 -- field. It should eventually be changed to just UTCTime.

43 -- field. It should eventually be changed to just UTCTime.

48 , pkgTagTime :: Maybe UTCTime

44 , pkgTagTime :: Maybe UTCTime

49 , pkgModules :: [Module]

45 , pkgModules :: [Module]

50− , pkgBookmarks :: [Bookmark]

46+ , pkgModuleMap :: Map P.ModuleName PackageName

51 , pkgResolvedDependencies :: [(PackageName, Version)]

47 , pkgResolvedDependencies :: [(PackageName, Version)]

52 , pkgGithub :: (GithubUser, GithubRepo)

48 , pkgGithub :: (GithubUser, GithubRepo)

53 , pkgUploader :: a

49 , pkgUploader :: a

@@ -70,7 +66,7 @@ verifyPackage verifiedUser Package{..} =

70 pkgVersionTag

66 pkgVersionTag

71 pkgTagTime

67 pkgTagTime

72 pkgModules

68 pkgModules

73− pkgBookmarks

69+ pkgModuleMap

74 pkgResolvedDependencies

70 pkgResolvedDependencies

75 pkgGithub

71 pkgGithub

76 verifiedUser

72 verifiedUser

@@ -188,8 +184,6 @@ convertFundepsToStrings args fundeps =

188 ) $ argsVec V.!? i

184 ) $ argsVec V.!? i

189 toArgs from to = (map getArg from, map getArg to)

185 toArgs from to = (map getArg from, map getArg to)

190

186

191−type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)))

192−

193declInfoToString :: DeclarationInfo -> Text

187declInfoToString :: DeclarationInfo -> Text

194declInfoToString (ValueDeclaration _) = "value"

188declInfoToString (ValueDeclaration _) = "value"

195declInfoToString (DataDeclaration _ _) = "data"

189declInfoToString (DataDeclaration _ _) = "data"

@@ -199,6 +193,23 @@ declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

199declInfoToString (AliasDeclaration _ _) = "alias"

193declInfoToString (AliasDeclaration _ _) = "alias"

200declInfoToString ExternKindDeclaration = "kind"

194declInfoToString ExternKindDeclaration = "kind"

201

195

196+declInfoNamespace :: DeclarationInfo -> Namespace

197+declInfoNamespace = \case

198+ ValueDeclaration{} ->

199+ ValueLevel

200+ DataDeclaration{} ->

201+ TypeLevel

202+ ExternDataDeclaration{} ->

203+ TypeLevel

204+ TypeSynonymDeclaration{} ->

205+ TypeLevel

206+ TypeClassDeclaration{} ->

207+ TypeLevel

208+ AliasDeclaration _ alias ->

209+ either (const TypeLevel) (const ValueLevel) (P.disqualify alias)

210+ ExternKindDeclaration{} ->

211+ KindLevel

212+

202isTypeClass :: Declaration -> Bool

213isTypeClass :: Declaration -> Bool

203isTypeClass Declaration{..} =

214isTypeClass Declaration{..} =

204 case declInfo of

215 case declInfo of

@@ -274,6 +285,20 @@ childDeclInfoToString (ChildInstance _ _) = "instance"

274childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

285childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

275childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

286childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

276

287

288+childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace

289+childDeclInfoNamespace =

290+ -- We could just write this as `const ValueLevel` but by doing it this way,

291+ -- if another constructor is added, we get a warning which acts as a prompt

292+ -- to update this, instead of having this function (possibly incorrectly)

293+ -- just return ValueLevel for the new constructor.

294+ \case

295+ ChildInstance{} ->

296+ ValueLevel

297+ ChildDataConstructor{} ->

298+ ValueLevel

299+ ChildTypeClassMember{} ->

300+ ValueLevel

301+

277isTypeClassMember :: ChildDeclaration -> Bool

302isTypeClassMember :: ChildDeclaration -> Bool

278isTypeClassMember ChildDeclaration{..} =

303isTypeClassMember ChildDeclaration{..} =

279 case cdeclInfo of

304 case cdeclInfo of

@@ -308,8 +333,6 @@ data PackageError

308 | InvalidTime

333 | InvalidTime

309 deriving (Show, Eq, Ord)

334 deriving (Show, Eq, Ord)

310

335

311−type Bookmark = InPackage (P.ModuleName, Text)

312−

313data InPackage a

336data InPackage a

314 = Local a

337 = Local a

315 | FromDep PackageName a

338 | FromDep PackageName a

@@ -333,10 +356,10 @@ ignorePackage (FromDep _ x) = x

333----------------------

356----------------------

334-- Parsing

357-- Parsing

335

358

336−parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage

359+parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage

337parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion

360parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion

338

361

339−parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage

362+parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage

340parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion

363parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion

341

364

342asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)

365asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)

@@ -353,11 +376,15 @@ asPackage minimumVersion uploader = do

353 <*> key "versionTag" asText

376 <*> key "versionTag" asText

354 <*> keyMay "tagTime" (withString parseTimeEither)

377 <*> keyMay "tagTime" (withString parseTimeEither)

355 <*> key "modules" (eachInArray asModule)

378 <*> key "modules" (eachInArray asModule)

356− <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

379+ <*> moduleMap

357 <*> key "resolvedDependencies" asResolvedDependencies

380 <*> key "resolvedDependencies" asResolvedDependencies

358 <*> key "github" asGithub

381 <*> key "github" asGithub

359 <*> key "uploader" uploader

382 <*> key "uploader" uploader

360 <*> pure compilerVersion

383 <*> pure compilerVersion

384+ where

385+ moduleMap =

386+ key "moduleMap" asModuleMap

387+ `pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta)

361

388

362parseTimeEither :: String -> Either PackageError UTCTime

389parseTimeEither :: String -> Either PackageError UTCTime

363parseTimeEither =

390parseTimeEither =

@@ -444,9 +471,10 @@ asReExport =

444 asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)

471 asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)

445 asReExportModuleName =

472 asReExportModuleName =

446 asInPackage fromAesonParser .! ErrorInPackageMeta

473 asInPackage fromAesonParser .! ErrorInPackageMeta

447− <|> fmap Local fromAesonParser

474+ `pOr` fmap Local fromAesonParser

448

475

476+pOr :: Parse e a -> Parse e a -> Parse e a

449− (<|>) p q = catchError p (const q)

477+p `pOr` q = catchError p (const q)

450

478

451asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)

479asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)

452asInPackage inner =

480asInPackage inner =

@@ -559,20 +587,38 @@ asQualifiedProperName = fromAesonParser

559asQualifiedIdent :: Parse e (P.Qualified P.Ident)

587asQualifiedIdent :: Parse e (P.Qualified P.Ident)

560asQualifiedIdent = fromAesonParser

588asQualifiedIdent = fromAesonParser

561

589

562−asBookmarks :: Parse BowerError [Bookmark]

590+asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)

563−asBookmarks = eachInArray asBookmark

591+asModuleMap =

592+ Map.fromList <$>

593+ eachInObjectWithKey (Right . P.moduleNameFromString)

594+ (withText parsePackageName')

564

595

565−asBookmark :: Parse BowerError Bookmark

596+-- This is here to preserve backwards compatibility with compilers which used

566−asBookmark =

597+-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should

567− asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)

598+-- remove this after the next breaking change to the JSON.

568− <*> nth 1 asText)

599+bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName)

600+bookmarksAsModuleMap =

601+ convert <$>

602+ eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText)))

603+

604+ where

605+ convert :: [InPackage P.ModuleName] -> Map P.ModuleName PackageName

606+ convert = Map.fromList . mapMaybe toTuple

607+

608+ toTuple (Local _) = Nothing

609+ toTuple (FromDep pkgName mn) = Just (mn, pkgName)

569

610

570asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

611asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

571asResolvedDependencies =

612asResolvedDependencies =

613+ eachInObjectWithKey parsePackageName' asVersion

614+

615+parsePackageName' :: Text -> Either PackageError PackageName

616+parsePackageName' =

572− eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion

617+ mapLeft ErrorInPackageMeta . parsePackageName

573− where

618+

619+mapLeft :: (a -> a') -> Either a b -> Either a' b

574− mapLeft f (Left x) = Left (f x)

620+mapLeft f (Left x) = Left (f x)

575− mapLeft _ (Right x) = Right x

621+mapLeft _ (Right x) = Right x

576

622

577asGithub :: Parse e (GithubUser, GithubRepo)

623asGithub :: Parse e (GithubUser, GithubRepo)

578asGithub = (,) <$> nth 0 (GithubUser <$> asText)

624asGithub = (,) <$> nth 0 (GithubUser <$> asText)

@@ -593,7 +639,9 @@ instance A.ToJSON a => A.ToJSON (Package a) where

593 , "version" .= showVersion pkgVersion

639 , "version" .= showVersion pkgVersion

594 , "versionTag" .= pkgVersionTag

640 , "versionTag" .= pkgVersionTag

595 , "modules" .= pkgModules

641 , "modules" .= pkgModules

596− , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks

642+ , "moduleMap" .= assocListToJSON P.runModuleName

643+ runPackageName

644+ (Map.toList pkgModuleMap)

597 , "resolvedDependencies" .= assocListToJSON runPackageName

645 , "resolvedDependencies" .= assocListToJSON runPackageName

598 (T.pack . showVersion)

646 (T.pack . showVersion)

599 pkgResolvedDependencies

647 pkgResolvedDependencies

src/Language/PureScript/Environment.hs+6−3

@@ -347,7 +347,7 @@ primKinds =

347

348-- |

349-- The primitive types in the external javascript environment with their

350−-- associated kinds. There are also pseudo `Fail` and `Partial` types

350+-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types

351-- that correspond to the classes with the same names.

352--

353primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

@@ -363,20 +363,23 @@ primTypes =

363 , (primName "Boolean", (kindType, ExternData))

364 , (primName "Partial", (kindType, ExternData))

365 , (primName "Fail", (FunKind kindSymbol kindType, ExternData))

366+ , (primName "Warn", (FunKind kindSymbol kindType, ExternData))

366 , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

367 , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

367 , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

368 , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

368 ]

369 ]

369

370

370-- |

371-- |

371−-- The primitive class map. This just contains the `Fail` and `Partial`

372+-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`

372-- classes. `Partial` is used as a kind of magic constraint for partial

373-- classes. `Partial` is used as a kind of magic constraint for partial

373−-- functions. `Fail` is used for user-defined type errors.

374+-- functions. `Fail` is used for user-defined type errors. `Warn` for

375+-- user-defined warnings.

374--

376--

375primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

377primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

376primClasses =

378primClasses =

377 M.fromList

379 M.fromList

378 [ (primName "Partial", (makeTypeClassData [] [] [] []))

380 [ (primName "Partial", (makeTypeClassData [] [] [] []))

379 , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

381 , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

382+ , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

380 ]

383 ]

381

384

382-- |

385-- |

src/Language/PureScript/Errors.hs+79−87

@@ -6,44 +6,40 @@ module Language.PureScript.Errors

6 , module Language.PureScript.Errors

7 ) where

8

9−import Prelude.Compat

9+import Prelude.Compat

10−

10+

11−import Control.Arrow ((&&&))

11+import Control.Arrow ((&&&))

12−import Control.Monad

12+import Control.Monad

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

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

14−import Control.Monad.Trans.State.Lazy

14+import Control.Monad.Trans.State.Lazy

15−import Control.Monad.Writer

15+import Control.Monad.Writer

16−

17−import Data.Char (isSpace)

16+import Data.Char (isSpace)

18−import Data.Either (lefts, rights)

17+import Data.Either (lefts, rights)

19−import Data.Foldable (fold)

18+import Data.Foldable (fold)

20−import Data.Functor.Identity (Identity(..))

19+import Data.Functor.Identity (Identity(..))

21−import Data.List (transpose, nub, nubBy, sortBy, partition)

20+import Data.List (transpose, nub, nubBy, sortBy, partition)

22−import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

21+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

23−import Data.Ord (comparing)

22+import Data.Ord (comparing)

24import qualified Data.Map as M

23import qualified Data.Map as M

25import qualified Data.Text as T

24import qualified Data.Text as T

26−import Data.Text (Text)

25+import Data.Text (Text)

27−

28−import Language.PureScript.AST

26+import Language.PureScript.AST

29−import Language.PureScript.Crash

30−import Language.PureScript.Environment

31−import Language.PureScript.Names

32−import Language.PureScript.Pretty

33−import Language.PureScript.Traversals

34−import Language.PureScript.Types

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

36−import Language.PureScript.Pretty.Common (before, endWith)

37import qualified Language.PureScript.Bundle as Bundle

27import qualified Language.PureScript.Bundle as Bundle

38import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

39−

29+import Language.PureScript.Crash

30+import Language.PureScript.Environment

31+import Language.PureScript.Label (Label(..))

32+import Language.PureScript.Names

33+import Language.PureScript.Pretty

34+import Language.PureScript.Pretty.Common (before, endWith)

35+import Language.PureScript.Traversals

36+import Language.PureScript.Types

37+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

40import qualified System.Console.ANSI as ANSI

38import qualified System.Console.ANSI as ANSI

41−

42import qualified Text.Parsec as P

39import qualified Text.Parsec as P

43import qualified Text.Parsec.Error as PE

40import qualified Text.Parsec.Error as PE

41+import Text.Parsec.Error (Message(..))

44import qualified Text.PrettyPrint.Boxes as Box

42import qualified Text.PrettyPrint.Boxes as Box

45−import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

46−import Text.Parsec.Error (Message(..))

47

43

48newtype ErrorSuggestion = ErrorSuggestion Text

44newtype ErrorSuggestion = ErrorSuggestion Text

49

45

@@ -72,11 +68,10 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt

72 shouldStrip (PositionedError _) = True

68 shouldStrip (PositionedError _) = True

73 shouldStrip _ = False

69 shouldStrip _ = False

74

70

75−-- |

76−-- Get the error code for a particular error type

71+-- | Get the error code for a particular error type

77−--

78errorCode :: ErrorMessage -> Text

72errorCode :: ErrorMessage -> Text

79errorCode em = case unwrapErrorMessage em of

73errorCode em = case unwrapErrorMessage em of

74+ ModuleNotFound{} -> "ModuleNotFound"

80 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

75 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

81 ErrorParsingModule{} -> "ErrorParsingModule"

76 ErrorParsingModule{} -> "ErrorParsingModule"

82 MissingFFIModule{} -> "MissingFFIModule"

77 MissingFFIModule{} -> "MissingFFIModule"

@@ -168,31 +163,27 @@ errorCode em = case unwrapErrorMessage em of

168 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

163 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

169 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

164 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

170 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

165 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

171− DeprecatedRequirePath{} -> "DeprecatedRequirePath"

172 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

166 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

173 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

167 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

174 ExpectedWildcard{} -> "ExpectedWildcard"

168 ExpectedWildcard{} -> "ExpectedWildcard"

175 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

169 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

170+ ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"

171+ UserDefinedWarning{} -> "UserDefinedWarning"

176

172

177−-- |

178−-- A stack trace for an error

173+-- | A stack trace for an error

179−--

180newtype MultipleErrors = MultipleErrors

174newtype MultipleErrors = MultipleErrors

181− { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

175+ { runMultipleErrors :: [ErrorMessage]

176+ } deriving (Show, Monoid)

182

177

183-- | Check whether a collection of errors is empty or not.

178-- | Check whether a collection of errors is empty or not.

184nonEmpty :: MultipleErrors -> Bool

179nonEmpty :: MultipleErrors -> Bool

185nonEmpty = not . null . runMultipleErrors

180nonEmpty = not . null . runMultipleErrors

186

181

187−-- |

188−-- Create an error set from a single simple error message

182+-- | Create an error set from a single simple error message

189−--

190errorMessage :: SimpleErrorMessage -> MultipleErrors

183errorMessage :: SimpleErrorMessage -> MultipleErrors

191errorMessage err = MultipleErrors [ErrorMessage [] err]

184errorMessage err = MultipleErrors [ErrorMessage [] err]

192

185

193−-- |

194−-- Create an error set from a single error message

186+-- | Create an error set from a single error message

195−--

196singleError :: ErrorMessage -> MultipleErrors

187singleError :: ErrorMessage -> MultipleErrors

197singleError = MultipleErrors . pure

188singleError = MultipleErrors . pure

198

189

@@ -225,15 +216,12 @@ defaultUnknownMap = TypeMap M.empty M.empty 0

225-- | How critical the issue is

216-- | How critical the issue is

226data Level = Error | Warning deriving Show

217data Level = Error | Warning deriving Show

227

218

228−-- |

229−-- Extract nested error messages from wrapper errors

219+-- | Extract nested error messages from wrapper errors

230−--

231unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

220unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

232unwrapErrorMessage (ErrorMessage _ se) = se

221unwrapErrorMessage (ErrorMessage _ se) = se

233

222

234replaceUnknowns :: Type -> State TypeMap Type

223replaceUnknowns :: Type -> State TypeMap Type

235−replaceUnknowns = everywhereOnTypesM replaceTypes

224+replaceUnknowns = everywhereOnTypesM replaceTypes where

236− where

237 replaceTypes :: Type -> State TypeMap Type

225 replaceTypes :: Type -> State TypeMap Type

238 replaceTypes (TUnknown u) = do

226 replaceTypes (TUnknown u) = do

239 m <- get

227 m <- get

@@ -386,10 +374,7 @@ defaultPPEOptions = PPEOptions

386 , ppeShowDocs = True

374 , ppeShowDocs = True

387 }

375 }

388

376

389−

390−-- |

391−-- Pretty print a single error, simplifying if necessary

377+-- | Pretty print a single error, simplifying if necessary

392−--

393prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box

378prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box

394prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do

379prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do

395 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

380 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

@@ -430,6 +415,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

430 unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"

415 unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"

431

416

432 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

417 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

418+ renderSimpleErrorMessage (ModuleNotFound mn) =

419+ paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found."

420+ , line "Make sure the source file exists, and that it has been provided as an input to psc."

421+ ]

433 renderSimpleErrorMessage (CannotGetFileInfo path) =

422 renderSimpleErrorMessage (CannotGetFileInfo path) =

434 paras [ line "Unable to read file info: "

423 paras [ line "Unable to read file info: "

435 , indent . lineS $ path

424 , indent . lineS $ path

@@ -691,7 +680,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

691 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

680 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

692 line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)

681 line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)

693 renderSimpleErrorMessage (ExpectedType ty kind) =

682 renderSimpleErrorMessage (ExpectedType ty kind) =

694− paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."

683+ paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."

695 , line "The error arises from the type"

684 , line "The error arises from the type"

696 , markCodeBox $ indent $ typeAsBox ty

685 , markCodeBox $ indent $ typeAsBox ty

697 , line "having the kind"

686 , line "having the kind"

@@ -863,9 +852,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

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

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

864 ]

853 ]

865

854

866− renderSimpleErrorMessage DeprecatedRequirePath =

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

868−

869 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

855 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

870 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

856 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

871 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

857 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

@@ -885,6 +871,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

885 paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

871 paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

886 ]

872 ]

887

873

874+ renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =

875+ paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>

876+ " expects " <> T.pack (show expected) <> " argument(s)."

877+ , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>

878+ T.pack (show actual) <> "."

879+ ]

880+

881+ renderSimpleErrorMessage (UserDefinedWarning msgTy) =

882+ let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in

883+ paras [ line "A custom warning occurred while solving type class constraints:"

884+ , indent msg

885+ ]

886+

888 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

887 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

889 renderHint (ErrorUnifyingTypes t1 t2) detail =

888 renderHint (ErrorUnifyingTypes t1 t2) detail =

890 paras [ detail

889 paras [ detail

@@ -1165,15 +1164,11 @@ prettyPrintRef (ReExportRef _ _) =

1165prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1164prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1166 prettyPrintRef ref

1165 prettyPrintRef ref

1167

1166

1168−-- |

1169−-- Pretty print multiple errors

1167+-- | Pretty print multiple errors

1170−--

1171prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String

1168prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String

1172prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions

1169prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions

1173

1170

1174−-- |

1175−-- Pretty print multiple warnings

1171+-- | Pretty print multiple warnings

1176−--

1177prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String

1172prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String

1178prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions

1173prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions

1179

1174

@@ -1204,11 +1199,10 @@ prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =

1204prettyPrintParseError :: P.ParseError -> Box.Box

1199prettyPrintParseError :: P.ParseError -> Box.Box

1205prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages

1200prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages

1206

1201

1207−-- |

1208−-- Pretty print ParseError detail messages.

1202+-- | Pretty print 'ParseError' detail messages.

1209−--

1210−-- Adapted from 'Text.Parsec.Error.showErrorMessages', see <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.

1211--

1203--

1204+-- Adapted from 'Text.Parsec.Error.showErrorMessages'.

1205+-- See <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.

1212prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box

1206prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box

1213prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs

1207prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs

1214 | null msgs = Box.text msgUnknown

1208 | null msgs = Box.text msgUnknown

@@ -1277,9 +1271,7 @@ toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

1277 | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)

1271 | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)

1278toTypelevelString _ = Nothing

1272toTypelevelString _ = Nothing

1279

1273

1280−-- |

1281−-- Rethrow an error with a more detailed error message in the case of failure

1274+-- | Rethrow an error with a more detailed error message in the case of failure

1282−--

1283rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1275rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1284rethrow f = flip catchError $ \e -> throwError (f e)

1276rethrow f = flip catchError $ \e -> throwError (f e)

1285

1277

@@ -1292,9 +1284,7 @@ reflectErrors ma = ma >>= either throwError return

1292warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a

1284warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a

1293warnAndRethrow f = rethrow f . censor f

1285warnAndRethrow f = rethrow f . censor f

1294

1286

1295−-- |

1296−-- Rethrow an error with source position information

1287+-- | Rethrow an error with source position information

1297−--

1298rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

1288rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

1299rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))

1289rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))

1300

1290

@@ -1307,10 +1297,8 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

1307withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

1297withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

1308withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

1298withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

1309

1299

1310−-- |

1311−-- Runs a computation listening for warnings and then escalating any warnings

1300+-- | Runs a computation listening for warnings and then escalating any warnings

1312-- that match the predicate to error status.

1301-- that match the predicate to error status.

1313−--

1314escalateWarningWhen

1302escalateWarningWhen

1315 :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)

1303 :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)

1316 => (ErrorMessage -> Bool)

1304 => (ErrorMessage -> Bool)

@@ -1323,16 +1311,20 @@ escalateWarningWhen isError ma = do

1323 unless (null errors) $ throwError $ MultipleErrors errors

1311 unless (null errors) $ throwError $ MultipleErrors errors

1324 return a

1312 return a

1325

1313

1326−-- |

1327−-- Collect errors in in parallel

1314+-- | Collect errors in in parallel

1328−--

1315+parU

1316+ :: forall m a b

1329−parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]

1317+ . MonadError MultipleErrors m

1318+ => [a]

1319+ -> (a -> m b)

1320+ -> m [b]

1321+parU xs f =

1330−parU xs f = forM xs (withError . f) >>= collectErrors

1322+ forM xs (withError . f) >>= collectErrors

1331 where

1323 where

1332− withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)

1324+ withError :: m b -> m (Either MultipleErrors b)

1333− withError u = catchError (Right <$> u) (return . Left)

1325+ withError u = catchError (Right <$> u) (return . Left)

1334

1326

1335− collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]

1327+ collectErrors :: [Either MultipleErrors b] -> m [b]

1336− collectErrors es = case lefts es of

1328+ collectErrors es = case lefts es of

1337− [] -> return $ rights es

1329+ [] -> return $ rights es

1338− errs -> throwError $ fold errs

1330+ errs -> throwError $ fold errs

src/Language/PureScript/Make.hs+80−87

@@ -20,53 +20,51 @@ module Language.PureScript.Make

20 , inferForeignModules

21 ) where

22

23−import Prelude.Compat

23+import Prelude.Compat

24−

24+

25−import Control.Concurrent.Lifted as C

25+import Control.Concurrent.Lifted as C

26−import Control.Monad hiding (sequence)

26+import Control.Monad hiding (sequence)

27−import Control.Monad.Base (MonadBase(..))

27+import Control.Monad.Base (MonadBase(..))

28−import Control.Monad.Error.Class (MonadError(..))

28+import Control.Monad.Error.Class (MonadError(..))

29−import Control.Monad.IO.Class

29+import Control.Monad.IO.Class

30−import Control.Monad.Logger

30+import Control.Monad.Logger

31−import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

31+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

32−import Control.Monad.Supply

32+import Control.Monad.Supply

33−import Control.Monad.Trans.Class (MonadTrans(..))

33+import Control.Monad.Trans.Class (MonadTrans(..))

34−import Control.Monad.Trans.Control (MonadBaseControl(..))

34+import Control.Monad.Trans.Control (MonadBaseControl(..))

35−import Control.Monad.Trans.Except

35+import Control.Monad.Trans.Except

36−import Control.Monad.Writer.Class (MonadWriter(..))

36+import Control.Monad.Writer.Class (MonadWriter(..))

37−

38−import Data.Aeson (encode, decode)

37+import Data.Aeson (encode, decode)

39import qualified Data.Aeson as Aeson

38import qualified Data.Aeson as Aeson

40−import Data.Either (partitionEithers)

39+import Data.Either (partitionEithers)

41−import Data.Function (on)

40+import Data.Function (on)

42−import Data.Foldable (for_)

41+import Data.Foldable (for_)

43−import Data.List (foldl', sortBy, groupBy)

42+import Data.List (foldl', sortBy, groupBy)

44−import Data.Maybe (fromMaybe, catMaybes)

43+import Data.Maybe (fromMaybe, catMaybes)

45−import Data.Monoid ((<>))

44+import Data.Monoid ((<>))

46−import Data.Time.Clock

45+import Data.Time.Clock

47−import Data.Traversable (for)

46+import Data.Traversable (for)

48−import Data.Version (showVersion)

47+import Data.Version (showVersion)

49import qualified Data.ByteString.Lazy as B

48import qualified Data.ByteString.Lazy as B

50import qualified Data.ByteString.UTF8 as BU8

49import qualified Data.ByteString.UTF8 as BU8

51import qualified Data.Map as M

50import qualified Data.Map as M

52import qualified Data.Set as S

51import qualified Data.Set as S

53import qualified Data.Text as T

52import qualified Data.Text as T

54import qualified Data.Text.Encoding as TE

53import qualified Data.Text.Encoding as TE

55−

56−import Language.PureScript.AST

54+import Language.PureScript.AST

57−import Language.PureScript.Crash

55+import Language.PureScript.Crash

58−import Language.PureScript.Environment

56+import Language.PureScript.Environment

59−import Language.PureScript.Errors

57+import Language.PureScript.Errors

60−import Language.PureScript.Externs

58+import Language.PureScript.Externs

61−import Language.PureScript.Linter

59+import Language.PureScript.Linter

62−import Language.PureScript.ModuleDependencies

60+import Language.PureScript.ModuleDependencies

63−import Language.PureScript.Names

61+import Language.PureScript.Names

64−import Language.PureScript.Options

62+import Language.PureScript.Options

65−import Language.PureScript.Pretty

63+import Language.PureScript.Pretty

66−import Language.PureScript.Pretty.Common(SMap(..))

64+import Language.PureScript.Pretty.Common(SMap(..))

67−import Language.PureScript.Renamer

65+import Language.PureScript.Renamer

68−import Language.PureScript.Sugar

66+import Language.PureScript.Sugar

69−import Language.PureScript.TypeChecker

67+import Language.PureScript.TypeChecker

70import qualified Language.JavaScript.Parser as JS

68import qualified Language.JavaScript.Parser as JS

71import qualified Language.PureScript.Bundle as Bundle

69import qualified Language.PureScript.Bundle as Bundle

72import qualified Language.PureScript.CodeGen.JS as J

70import qualified Language.PureScript.CodeGen.JS as J

@@ -74,21 +72,18 @@ import qualified Language.PureScript.Constants as C

74import qualified Language.PureScript.CoreFn as CF

72import qualified Language.PureScript.CoreFn as CF

75import qualified Language.PureScript.CoreFn.ToJSON as CFJ

73import qualified Language.PureScript.CoreFn.ToJSON as CFJ

76import qualified Language.PureScript.Parser as PSParser

74import qualified Language.PureScript.Parser as PSParser

77−

78import qualified Paths_purescript as Paths

75import qualified Paths_purescript as Paths

79−

80−import SourceMap

76+import SourceMap

81−import SourceMap.Types

77+import SourceMap.Types

82−

83−import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

78+import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

84−import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

79+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

85−import System.IO.Error (tryIOError)

80+import System.IO.Error (tryIOError)

86−

87import qualified Text.Parsec as Parsec

81import qualified Text.Parsec as Parsec

88

82

89-- | Progress messages from the make process

83-- | Progress messages from the make process

90data ProgressMessage

84data ProgressMessage

91 = CompilingModule ModuleName

85 = CompilingModule ModuleName

86+ -- ^ Compilation started for the specified module

92 deriving (Show, Eq, Ord)

87 deriving (Show, Eq, Ord)

93

88

94-- | Render a progress message

89-- | Render a progress message

@@ -102,7 +97,6 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule

102-- * The particular backend being used (Javascript, C++11, etc.)

97-- * The particular backend being used (Javascript, C++11, etc.)

103--

98--

104-- * The details of how files are read/written etc.

99-- * The details of how files are read/written etc.

105−--

106data MakeActions m = MakeActions

100data MakeActions m = MakeActions

107 { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

101 { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

108 -- ^ Get the timestamp for the input file(s) for a module. If there are multiple

102 -- ^ Get the timestamp for the input file(s) for a module. If there are multiple

@@ -121,26 +115,26 @@ data MakeActions m = MakeActions

121 -- ^ Respond to a progress update.

115 -- ^ Respond to a progress update.

122 }

116 }

123

117

124−-- |

125−-- Generated code for an externs file.

118+-- | Generated code for an externs file.

126−--

127type Externs = B.ByteString

119type Externs = B.ByteString

128

120

129−-- |

130−-- Determines when to rebuild a module

121+-- | Determines when to rebuild a module

131−--

132data RebuildPolicy

122data RebuildPolicy

133 -- | Never rebuild this module

123 -- | Never rebuild this module

134 = RebuildNever

124 = RebuildNever

135 -- | Always rebuild this module

125 -- | Always rebuild this module

136 | RebuildAlways deriving (Show, Eq, Ord)

126 | RebuildAlways deriving (Show, Eq, Ord)

137

127

138−-- | Rebuild a single module

128+-- | Rebuild a single module.

129+--

130+-- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).

131+rebuildModule

132+ :: forall m

139−rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

133+ . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

140− => MakeActions m

134+ => MakeActions m

141− -> [ExternsFile]

135+ -> [ExternsFile]

142− -> Module

136+ -> Module

143− -> m ExternsFile

137+ -> m ExternsFile

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

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

145 progress $ CompilingModule moduleName

139 progress $ CompilingModule moduleName

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

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

@@ -157,12 +151,10 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

157 evalSupplyT nextVar . codegen renamed env' . encode $ exts

151 evalSupplyT nextVar . codegen renamed env' . encode $ exts

158 return exts

152 return exts

159

153

160−-- |

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

154+-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file.

162--

155--

163-- If timestamps have not changed, the externs file can be used to provide the module's types without

156-- If timestamps have not changed, the externs file can be used to provide the module's types without

164-- having to typecheck the module again.

157-- having to typecheck the module again.

165−--

166make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

158make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

167 => MakeActions m

159 => MakeActions m

168 -> [Module]

160 -> [Module]

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

244 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs

236 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs

245 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors

237 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors

246

238

247− maximumMaybe :: (Ord a) => [a] -> Maybe a

239+ maximumMaybe :: Ord a => [a] -> Maybe a

248 maximumMaybe [] = Nothing

240 maximumMaybe [] = Nothing

249 maximumMaybe xs = Just $ maximum xs

241 maximumMaybe xs = Just $ maximum xs

250

242

@@ -262,11 +254,10 @@ make ma@MakeActions{..} ms = do

262importPrim :: Module -> Module

254importPrim :: Module -> Module

263importPrim = addDefaultImport (ModuleName [ProperName C.prim])

255importPrim = addDefaultImport (ModuleName [ProperName C.prim])

264

256

265−-- |

266−-- A monad for running make actions

257+-- | A monad for running make actions

267−--

258+newtype Make a = Make

268−newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }

259+ { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a

269− deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

260+ } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

270

261

271instance MonadBase IO Make where

262instance MonadBase IO Make where

272 liftBase = liftIO

263 liftBase = liftIO

@@ -276,12 +267,12 @@ instance MonadBaseControl IO Make where

276 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)

267 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)

277 restoreM = Make . restoreM

268 restoreM = Make . restoreM

278

269

279−-- |

280−-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

270+-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

281−--

282runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)

271runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)

283runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake

272runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake

284

273

274+-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should

275+-- be rendered as 'ErrorMessage' values.

285makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a

276makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a

286makeIO f io = do

277makeIO f io = do

287 e <- liftIO $ tryIOError io

278 e <- liftIO $ tryIOError io

@@ -299,7 +290,8 @@ inferForeignModules

299 . MonadIO m

290 . MonadIO m

300 => M.Map ModuleName (Either RebuildPolicy FilePath)

291 => M.Map ModuleName (Either RebuildPolicy FilePath)

301 -> m (M.Map ModuleName FilePath)

292 -> m (M.Map ModuleName FilePath)

293+inferForeignModules =

302−inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule

294+ fmap (M.mapMaybe id) . traverse inferForeignModule

303 where

295 where

304 inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)

296 inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)

305 inferForeignModule (Left _) = return Nothing

297 inferForeignModule (Left _) = return Nothing

@@ -310,16 +302,19 @@ inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule

310 then return (Just jsFile)

302 then return (Just jsFile)

311 else return Nothing

303 else return Nothing

312

304

313−-- |

314−-- A set of make actions that read and write modules from the given directory.

305+-- | A set of make actions that read and write modules from the given directory.

315−--

306+buildMakeActions

307+ :: FilePath

316−buildMakeActions :: FilePath -- ^ the output directory

308+ -- ^ the output directory

309+ -> M.Map ModuleName (Either RebuildPolicy FilePath)

317− -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module

310+ -- ^ a map between module names and paths to the file containing the PureScript module

311+ -> M.Map ModuleName FilePath

318− -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module

312+ -- ^ a map between module name and the file containing the foreign javascript for the module

313+ -> Bool

319− -> Bool -- ^ Generate a prefix comment?

314+ -- ^ Generate a prefix comment?

320− -> MakeActions Make

315+ -> MakeActions Make

321buildMakeActions outputDir filePathMap foreigns usePrefix =

316buildMakeActions outputDir filePathMap foreigns usePrefix =

322− MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

317+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

323 where

318 where

324

319

325 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

320 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

@@ -421,10 +416,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

421 progress :: ProgressMessage -> Make ()

416 progress :: ProgressMessage -> Make ()

422 progress = liftIO . putStrLn . renderProgressMessage

417 progress = liftIO . putStrLn . renderProgressMessage

423

418

424−-- |

425−-- Check that the declarations in a given PureScript module match with those

419+-- | Check that the declarations in a given PureScript module match with those

426-- in its corresponding foreign module.

420-- in its corresponding foreign module.

427−--

428checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

421checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

429checkForeignDecls m path = do

422checkForeignDecls m path = do

430 jsStr <- lift $ readTextFile path

423 jsStr <- lift $ readTextFile path

src/Language/PureScript/ModuleDependencies.hs+41−77

@@ -1,24 +1,18 @@

1−-- |

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

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

3−--

4module Language.PureScript.ModuleDependencies

2module Language.PureScript.ModuleDependencies

5 ( sortModules

3 ( sortModules

6 , ModuleGraph

4 , ModuleGraph

7 ) where

5 ) where

8

6

9−import Prelude.Compat

7+import Protolude

10−

11−import Control.Monad.Error.Class (MonadError(..))

12−

13−import Data.Graph

14−import Data.List (nub)

15−import Data.Maybe (fromMaybe)

16

8

9+import Data.Graph

10+import qualified Data.Set as S

17−import Language.PureScript.AST

11+import Language.PureScript.AST

12+import qualified Language.PureScript.Constants as C

18−import Language.PureScript.Crash

13+import Language.PureScript.Crash

19−import Language.PureScript.Errors

14+import Language.PureScript.Errors

20−import Language.PureScript.Names

15+import Language.PureScript.Names

21−import Language.PureScript.Types

22

16

23-- | A list of modules with their transitive dependencies

17-- | A list of modules with their transitive dependencies

24type ModuleGraph = [(ModuleName, [ModuleName])]

18type ModuleGraph = [(ModuleName, [ModuleName])]

@@ -26,75 +20,45 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

26-- | Sort a collection of modules based on module dependencies.

20-- | Sort a collection of modules based on module dependencies.

27--

21--

28-- Reports an error if the module graph contains a cycle.

22-- Reports an error if the module graph contains a cycle.

29−--

23+sortModules

24+ :: forall m

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

25+ . MonadError MultipleErrors m

26+ => [Module]

27+ -> m ([Module], ModuleGraph)

31sortModules ms = do

28sortModules ms = do

32− let verts = map goModule ms

29+ let mns = S.fromList $ map getModuleName ms

30+ verts <- mapM (toGraphNode mns) ms

33− ms' <- mapM toModule $ stronglyConnComp verts

31+ ms' <- mapM toModule $ stronglyConnComp verts

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

32+ let (graph, fromVertex, toVertex) = graphFromEdges verts

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

33+ moduleGraph = do (_, mn, _) <- verts

36− let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

34+ let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

37− deps = reachable graph v

35+ deps = reachable graph v

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

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

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

37+ return (mn, filter (/= mn) (map toKey deps))

40− return (ms', moduleGraph)

38+ return (ms', moduleGraph)

41 where

39 where

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

40+ toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])

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

41+ toGraphNode mns m@(Module _ _ mn ds _) = do

44− let ams = concatMap extractQualAs ds

42+ let deps = ordNub (concatMap usedModules ds)

43+ forM_ deps $ \dep ->

44+ when (dep /= C.Prim && S.notMember dep mns) $

45+ throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep

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

46+ pure (m, getModuleName m, deps)

46

47

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

48+-- | Calculate a list of used modules based on explicit imports and qualified names.

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

49+usedModules :: Declaration -> [ModuleName]

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

50+usedModules d = f d where

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.

59−--

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

51+ f :: Declaration -> [ModuleName]

61−usedModules ams d =

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

52+ (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const [])

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

64− in nub (f d ++ g d)

65− where

66

53

67 forDecls :: Declaration -> [ModuleName]

54 forDecls :: Declaration -> [ModuleName]

68− forDecls (ImportDeclaration mn _ _) =

69− -- Regardless of whether an imported module is qualified we still need to

55+ -- 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.

56+ -- take into account its import to build an accurate list of dependencies.

71− [mn]

57+ forDecls (ImportDeclaration mn _ _) = [mn]

72− forDecls (FixityDeclaration fd)

73− | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]

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

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

76 forDecls _ = []

58 forDecls _ = []

77

59

78− forValues :: Expr -> [ModuleName]

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

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

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

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

83− forValues _ = []

84−

85− forTypes :: Type -> [ModuleName]

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

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

88− forTypes _ = []

89−

90− extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName

91− extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn

92− extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn

93−

94−-- |

95−-- Convert a strongly connected component of the module graph to a module

60+-- | Convert a strongly connected component of the module graph to a module

96−--

97−toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module

61+toModule :: MonadError MultipleErrors m => SCC Module -> m Module

98toModule (AcyclicSCC m) = return m

62toModule (AcyclicSCC m) = return m

99toModule (CyclicSCC [m]) = return m

63toModule (CyclicSCC [m]) = return m

100toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

64toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

src/Language/PureScript/Parser/Common.hs+49−73

@@ -1,52 +1,39 @@

1−-- |

1+-- | Useful common functions for building parsers

2−-- Constants and utility functions to be used when parsing

3−--

4module Language.PureScript.Parser.Common where

2module Language.PureScript.Parser.Common where

5

3

6−import Prelude.Compat

4+import Prelude.Compat

7

5

8−import Control.Applicative ((<|>))

6+import Control.Applicative ((<|>))

9−import Control.Monad (guard)

7+import Control.Monad (guard)

8+import Data.Maybe (fromMaybe)

10−import Data.Monoid ((<>))

9+import Data.Monoid ((<>))

11−import Data.Text (Text)

10+import Data.Text (Text)

12import qualified Data.Text as T

11import qualified Data.Text as T

13−

14−import Language.PureScript.AST.SourcePos

12+import Language.PureScript.AST.SourcePos

15−import Language.PureScript.Comments

13+import Language.PureScript.Comments

16−import Language.PureScript.Names

14+import Language.PureScript.Names

17−import Language.PureScript.Parser.Lexer

15+import Language.PureScript.Parser.Lexer

18−import Language.PureScript.Parser.State

16+import Language.PureScript.Parser.State

19−import Language.PureScript.PSString (PSString, mkString)

17+import Language.PureScript.PSString (PSString, mkString)

20−

21import qualified Text.Parsec as P

18import qualified Text.Parsec as P

22

19

23−-- |

24−-- Parse a general proper name.

20+-- | Parse a general proper name.

25−--

26properName :: TokenParser (ProperName a)

21properName :: TokenParser (ProperName a)

27properName = ProperName <$> uname

22properName = ProperName <$> uname

28

23

29−-- |

30−-- Parse a proper name for a type.

24+-- | Parse a proper name for a type.

31−--

32typeName :: TokenParser (ProperName 'TypeName)

25typeName :: TokenParser (ProperName 'TypeName)

33typeName = ProperName <$> tyname

26typeName = ProperName <$> tyname

34

27

35−-- |

36−-- Parse a proper name for a kind.

28+-- | Parse a proper name for a kind.

37−--

38kindName :: TokenParser (ProperName 'KindName)

29kindName :: TokenParser (ProperName 'KindName)

39kindName = ProperName <$> kiname

30kindName = ProperName <$> kiname

40

31

41−-- |

42−-- Parse a proper name for a data constructor.

32+-- | Parse a proper name for a data constructor.

43−--

44dataConstructorName :: TokenParser (ProperName 'ConstructorName)

33dataConstructorName :: TokenParser (ProperName 'ConstructorName)

45dataConstructorName = ProperName <$> dconsname

34dataConstructorName = ProperName <$> dconsname

46

35

47−-- |

48−-- Parse a module name

36+-- | Parse a module name

49−--

50moduleName :: TokenParser ModuleName

37moduleName :: TokenParser ModuleName

51moduleName = part []

38moduleName = part []

52 where

39 where

@@ -55,9 +42,7 @@ moduleName = part []

55 <|> (ModuleName . snoc path . ProperName <$> mname)

42 <|> (ModuleName . snoc path . ProperName <$> mname)

56 snoc path name = path ++ [name]

43 snoc path name = path ++ [name]

57

44

58−-- |

59−-- Parse a qualified name, i.e. M.name or just name

45+-- | Parse a qualified name, i.e. M.name or just name

60−--

61parseQualified :: TokenParser a -> TokenParser (Qualified a)

46parseQualified :: TokenParser a -> TokenParser (Qualified a)

62parseQualified parser = part []

47parseQualified parser = part []

63 where

48 where

@@ -67,42 +52,30 @@ parseQualified parser = part []

67 updatePath path name = path ++ [name]

52 updatePath path name = path ++ [name]

68 qual path = if null path then Nothing else Just $ ModuleName path

53 qual path = if null path then Nothing else Just $ ModuleName path

69

54

70−-- |

71−-- Parse an identifier.

55+-- | Parse an identifier.

72−--

73parseIdent :: TokenParser Ident

56parseIdent :: TokenParser Ident

74parseIdent = Ident <$> identifier

57parseIdent = Ident <$> identifier

75

58

76−-- |

77−-- Parse a label, which may look like an identifier or a string

59+-- | Parse a label, which may look like an identifier or a string

78−--

79parseLabel :: TokenParser PSString

60parseLabel :: TokenParser PSString

80parseLabel = (mkString <$> lname) <|> stringLiteral

61parseLabel = (mkString <$> lname) <|> stringLiteral

81

62

82−-- |

83−-- Parse an operator.

63+-- | Parse an operator.

84−--

85parseOperator :: TokenParser (OpName a)

64parseOperator :: TokenParser (OpName a)

86parseOperator = OpName <$> symbol

65parseOperator = OpName <$> symbol

87

66

88−-- |

89−-- Run the first parser, then match the second if possible, applying the specified function on a successful match

67+-- | Run the first parser, then match the second if possible, applying the specified function on a successful match

90−--

91augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

68augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

92augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

69augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

93

70

94−-- |

95−-- Run the first parser, then match the second zero or more times, applying the specified function for each match

71+-- | Run the first parser, then match the second zero or more times, applying the specified function for each match

96−--

97fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

72fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

98fold first' more combine = do

73fold first' more combine = do

99 a <- first'

74 a <- first'

100 bs <- P.many more

75 bs <- P.many more

101 return $ foldl combine a bs

76 return $ foldl combine a bs

102

77

103−-- |

104−-- Build a parser from a smaller parser and a list of parsers for postfix operators

78+-- | Build a parser from a smaller parser and a list of parsers for postfix operators

105−--

106buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

79buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

107buildPostfixParser fs first' = do

80buildPostfixParser fs first' = do

108 a <- first'

81 a <- first'

@@ -114,9 +87,7 @@ buildPostfixParser fs first' = do

114 Nothing -> return a

87 Nothing -> return a

115 Just a' -> go a'

88 Just a' -> go a'

116

89

117−-- |

118−-- Mark the current indentation level

90+-- | Mark the current indentation level

119−--

120mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a

91mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a

121mark p = do

92mark p = do

122 current <- indentationLevel <$> P.getState

93 current <- indentationLevel <$> P.getState

@@ -126,9 +97,7 @@ mark p = do

126 P.modifyState $ \st -> st { indentationLevel = current }

97 P.modifyState $ \st -> st { indentationLevel = current }

127 return a

98 return a

128

99

129−-- |

130−-- Check that the current identation level matches a predicate

100+-- | Check that the current identation level matches a predicate

131−--

132checkIndentation

101checkIndentation

133 :: (P.Column -> Text)

102 :: (P.Column -> Text)

134 -> (P.Column -> P.Column -> Bool)

103 -> (P.Column -> P.Column -> Bool)

@@ -138,32 +107,39 @@ checkIndentation mkMsg rel = do

138 current <- indentationLevel <$> P.getState

107 current <- indentationLevel <$> P.getState

139 guard (col `rel` current) P.<?> T.unpack (mkMsg current)

108 guard (col `rel` current) P.<?> T.unpack (mkMsg current)

140

109

141−-- |

142−-- Check that the current indentation level is past the current mark

110+-- | Check that the current indentation level is past the current mark

143−--

144indented :: P.Parsec s ParseState ()

111indented :: P.Parsec s ParseState ()

145indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)

112indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)

146

113

147−-- |

148−-- Check that the current indentation level is at the same indentation as the current mark

114+-- | Check that the current indentation level is at the same indentation as the current mark

149−--

150same :: P.Parsec s ParseState ()

115same :: P.Parsec s ParseState ()

151same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)

116same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)

152

117

153−-- |

154−-- Read the comments from the the next token, without consuming it

118+-- | Read the comments from the the next token, without consuming it

155−--

156readComments :: P.Parsec [PositionedToken] u [Comment]

119readComments :: P.Parsec [PositionedToken] u [Comment]

157readComments = P.lookAhead $ ptComments <$> P.anyToken

120readComments = P.lookAhead $ ptComments <$> P.anyToken

158

121

159−-- |

160−-- Run a parser

122+-- | Run a parser

161−--

162runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a

123runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a

163runTokenParser filePath p = P.runParser p (ParseState 0) filePath

124runTokenParser filePath p = P.runParser p (ParseState 0) filePath

164

125

165−-- |

166−-- Convert from Parsec sourcepos

126+-- | Convert from Parsec sourcepos

167−--

168toSourcePos :: P.SourcePos -> SourcePos

127toSourcePos :: P.SourcePos -> SourcePos

169toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

128toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

129+

130+-- | Read source position information and comments

131+withSourceSpan

132+ :: (SourceSpan -> [Comment] -> a -> b)

133+ -> P.Parsec [PositionedToken] u a

134+ -> P.Parsec [PositionedToken] u b

135+withSourceSpan f p = do

136+ start <- P.getPosition

137+ comments <- readComments

138+ x <- p

139+ end <- P.getPosition

140+ input <- P.getInput

141+ let end' = case input of

142+ pt:_ -> ptPrevEndPos pt

143+ _ -> Nothing

144+ let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end')

145+ return $ f sp comments x

src/Language/PureScript/Parser/Declarations.hs+85−119

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

1−-- |

2−-- Parsers for module definitions and declarations

1+-- | Parsers for module definitions and declarations

3−--

4module Language.PureScript.Parser.Declarations

2module Language.PureScript.Parser.Declarations

5 ( parseDeclaration

3 ( parseDeclaration

6 , parseModule

4 , parseModule

@@ -15,53 +13,32 @@ module Language.PureScript.Parser.Declarations

15 , toPositionedError

13 , toPositionedError

16 ) where

14 ) where

17

15

18−import Prelude hiding (lex)

16+import Prelude hiding (lex)

19−

17+

20−import Data.Functor (($>))

21−import Data.Maybe (fromMaybe)

22−import Data.Text (Text)

23−

24−import Control.Applicative

18+import Control.Applicative

25−import Control.Arrow ((+++))

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

26−import Control.Monad.Error.Class (MonadError(..))

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

27−import Control.Parallel.Strategies (withStrategy, parList, rseq)

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

28−

22+import Data.Bifunctor (first)

23+import Data.Functor (($>))

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

25+import qualified Data.List.NonEmpty as N

26+import Data.Maybe (fromMaybe)

27+import Data.Text (Text)

29−import Language.PureScript.AST

28+import Language.PureScript.AST

30−import Language.PureScript.Comments

31−import Language.PureScript.Environment

29+import Language.PureScript.Environment

32−import Language.PureScript.Errors

30+import Language.PureScript.Errors

33−import Language.PureScript.Kinds

31+import Language.PureScript.Kinds

34−import Language.PureScript.Names

32+import Language.PureScript.Names

35−import Language.PureScript.Types

36−import Language.PureScript.PSString (PSString, mkString)

37−import Language.PureScript.Parser.Common

33+import Language.PureScript.Parser.Common

38−import Language.PureScript.Parser.Kinds

34+import Language.PureScript.Parser.Kinds

39−import Language.PureScript.Parser.Lexer

35+import Language.PureScript.Parser.Lexer

40−import Language.PureScript.Parser.Types

36+import Language.PureScript.Parser.Types

41−

37+import Language.PureScript.PSString (PSString, mkString)

42−import qualified Language.PureScript.Parser.Common as C

38+import Language.PureScript.Types

43import qualified Text.Parsec as P

39import qualified Text.Parsec as P

44import qualified Text.Parsec.Expr as P

40import qualified Text.Parsec.Expr as P

45

41

46−-- |

47−-- Read source position information

48−--

49−withSourceSpan

50− :: (SourceSpan -> [Comment] -> a -> a)

51− -> P.Parsec [PositionedToken] u a

52− -> P.Parsec [PositionedToken] u a

53−withSourceSpan f p = do

54− start <- P.getPosition

55− comments <- C.readComments

56− x <- p

57− end <- P.getPosition

58− input <- P.getInput

59− let end' = case input of

60− pt:_ -> ptPrevEndPos pt

61− _ -> Nothing

62− let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end')

63− return $ f sp comments x

64−

65kindedIdent :: TokenParser (Text, Maybe Kind)

42kindedIdent :: TokenParser (Text, Maybe Kind)

66kindedIdent = (, Nothing) <$> identifier

43kindedIdent = (, Nothing) <$> identifier

67 <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

44 <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

@@ -91,7 +68,7 @@ parseValueDeclaration :: TokenParser Declaration

91parseValueDeclaration = do

68parseValueDeclaration = do

92 name <- parseIdent

69 name <- parseIdent

93 binders <- P.many parseBinderNoParens

70 binders <- P.many parseBinderNoParens

94− value <- Left <$> (C.indented *>

71+ value <- Left <$> (indented *>

95 P.many1 ((,) <$> parseGuard

72 P.many1 ((,) <$> parseGuard

96 <*> (indented *> equals *> parseValueWithWhereClause)

73 <*> (indented *> equals *> parseValueWithWhereClause)

97 ))

74 ))

@@ -100,13 +77,13 @@ parseValueDeclaration = do

100 where

77 where

101 parseValueWithWhereClause :: TokenParser Expr

78 parseValueWithWhereClause :: TokenParser Expr

102 parseValueWithWhereClause = do

79 parseValueWithWhereClause = do

103− C.indented

80+ indented

104 value <- parseValue

81 value <- parseValue

105 whereClause <- P.optionMaybe $ do

82 whereClause <- P.optionMaybe $ do

106− C.indented

83+ indented

107 reserved "where"

84 reserved "where"

108− C.indented

85+ indented

109− C.mark $ P.many1 (C.same *> parseLocalDeclaration)

86+ mark $ P.many1 (same *> parseLocalDeclaration)

110 return $ maybe value (`Let` value) whereClause

87 return $ maybe value (`Let` value) whereClause

111

88

112parseExternDeclaration :: TokenParser Declaration

89parseExternDeclaration :: TokenParser Declaration

@@ -237,9 +214,7 @@ parseDerivingInstanceDeclaration = do

237positioned :: TokenParser Declaration -> TokenParser Declaration

214positioned :: TokenParser Declaration -> TokenParser Declaration

238positioned = withSourceSpan PositionedDeclaration

215positioned = withSourceSpan PositionedDeclaration

239

216

240−-- |

241−-- Parse a single declaration

217+-- | Parse a single declaration

242−--

243parseDeclaration :: TokenParser Declaration

218parseDeclaration :: TokenParser Declaration

244parseDeclaration = positioned (P.choice

219parseDeclaration = positioned (P.choice

245 [ parseDataDeclaration

220 [ parseDataDeclaration

@@ -259,12 +234,10 @@ parseLocalDeclaration = positioned (P.choice

259 , parseValueDeclaration

234 , parseValueDeclaration

260 ] P.<?> "local declaration")

235 ] P.<?> "local declaration")

261

236

262−-- |

263−-- Parse a module header and a collection of declarations

237+-- | Parse a module header and a collection of declarations

264−--

265parseModule :: TokenParser Module

238parseModule :: TokenParser Module

266parseModule = do

239parseModule = do

267− comments <- C.readComments

240+ comments <- readComments

268 start <- P.getPosition

241 start <- P.getPosition

269 reserved "module"

242 reserved "module"

270 indented

243 indented

@@ -280,7 +253,7 @@ parseModule = do

280 return (imports ++ decls)

253 return (imports ++ decls)

281 _ <- P.eof

254 _ <- P.eof

282 end <- P.getPosition

255 end <- P.getPosition

283− let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end)

256+ let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)

284 return $ Module ss comments name decls exports

257 return $ Module ss comments name decls exports

285

258

286-- | Parse a collection of modules in parallel

259-- | Parse a collection of modules in parallel

@@ -301,7 +274,6 @@ parseModulesFromFiles toFilePath input =

301 inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)]

274 inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)]

302 inParallel = withStrategy (parList rseq)

275 inParallel = withStrategy (parList rseq)

303

276

304−

305-- | Parses a single module with FilePath for eventual parsing errors

277-- | Parses a single module with FilePath for eventual parsing errors

306parseModuleFromFile

278parseModuleFromFile

307 :: (k -> FilePath)

279 :: (k -> FilePath)

@@ -313,12 +285,12 @@ parseModuleFromFile toFilePath (k, content) = do

313 m <- runTokenParser filename parseModule ts

285 m <- runTokenParser filename parseModule ts

314 pure (k, m)

286 pure (k, m)

315

287

316−-- | Converts a @ParseError@ into a @PositionedError@

288+-- | Converts a 'ParseError' into a 'PositionedError'

317toPositionedError :: P.ParseError -> ErrorMessage

289toPositionedError :: P.ParseError -> ErrorMessage

318toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)

290toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)

319 where

291 where

320 name = (P.sourceName . P.errorPos) perr

292 name = (P.sourceName . P.errorPos) perr

321− start = (C.toSourcePos . P.errorPos) perr

293+ start = (toSourcePos . P.errorPos) perr

322 end = start

294 end = start

323

295

324booleanLiteral :: TokenParser Bool

296booleanLiteral :: TokenParser Bool

@@ -345,18 +317,18 @@ parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

345parseIdentifierAndValue :: TokenParser (PSString, Expr)

317parseIdentifierAndValue :: TokenParser (PSString, Expr)

346parseIdentifierAndValue =

318parseIdentifierAndValue =

347 do

319 do

348− name <- C.indented *> lname

320+ name <- indented *> lname

349 b <- P.option (Var $ Qualified Nothing (Ident name)) rest

321 b <- P.option (Var $ Qualified Nothing (Ident name)) rest

350 return (mkString name, b)

322 return (mkString name, b)

351− <|> (,) <$> (C.indented *> stringLiteral) <*> rest

323+ <|> (,) <$> (indented *> stringLiteral) <*> rest

352 where

324 where

353− rest = C.indented *> colon *> C.indented *> parseValue

325+ rest = indented *> colon *> indented *> parseValue

354

326

355parseAbs :: TokenParser Expr

327parseAbs :: TokenParser Expr

356parseAbs = do

328parseAbs = do

357 symbol' "\\"

329 symbol' "\\"

358− args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens)))

330+ args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens)))

359− C.indented *> rarrow

331+ indented *> rarrow

360 value <- parseValue

332 value <- parseValue

361 return $ toFunction args value

333 return $ toFunction args value

362 where

334 where

@@ -364,18 +336,18 @@ parseAbs = do

364 toFunction args value = foldr ($) value args

336 toFunction args value = foldr ($) value args

365

337

366parseVar :: TokenParser Expr

338parseVar :: TokenParser Expr

367−parseVar = Var <$> C.parseQualified C.parseIdent

339+parseVar = Var <$> parseQualified parseIdent

368

340

369parseConstructor :: TokenParser Expr

341parseConstructor :: TokenParser Expr

370−parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName

342+parseConstructor = Constructor <$> parseQualified dataConstructorName

371

343

372parseCase :: TokenParser Expr

344parseCase :: TokenParser Expr

373−parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

345+parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue)

374− <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

346+ <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative)))

375

347

376parseCaseAlternative :: TokenParser CaseAlternative

348parseCaseAlternative :: TokenParser CaseAlternative

377parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

349parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

378− <*> (Left <$> (C.indented *>

350+ <*> (Left <$> (indented *>

379 P.many1 ((,) <$> parseGuard

351 P.many1 ((,) <$> parseGuard

380 <*> (indented *> rarrow *> parseValue)

352 <*> (indented *> rarrow *> parseValue)

381 ))

353 ))

@@ -383,16 +355,16 @@ parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

383 P.<?> "case alternative"

355 P.<?> "case alternative"

384

356

385parseIfThenElse :: TokenParser Expr

357parseIfThenElse :: TokenParser Expr

386−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)

358+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue)

387− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)

359+ <*> (indented *> reserved "then" *> indented *> parseValue)

388− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)

360+ <*> (indented *> reserved "else" *> indented *> parseValue)

389

361

390parseLet :: TokenParser Expr

362parseLet :: TokenParser Expr

391parseLet = do

363parseLet = do

392 reserved "let"

364 reserved "let"

393− C.indented

365+ indented

394− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)

366+ ds <- mark $ P.many1 (same *> parseLocalDeclaration)

395− C.indented

367+ indented

396 reserved "in"

368 reserved "in"

397 result <- parseValue

369 result <- parseValue

398 return $ Let ds result

370 return $ Let ds result

@@ -418,9 +390,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice

418 , parseHole

390 , parseHole

419 ]

391 ]

420

392

421−-- |

422−-- Parse an expression in backticks or an operator

393+-- | Parse an expression in backticks or an operator

423−--

424parseInfixExpr :: TokenParser Expr

394parseInfixExpr :: TokenParser Expr

425parseInfixExpr

395parseInfixExpr

426 = P.between tick tick parseValue

396 = P.between tick tick parseValue

@@ -429,28 +399,29 @@ parseInfixExpr

429parseHole :: TokenParser Expr

399parseHole :: TokenParser Expr

430parseHole = Hole <$> holeLit

400parseHole = Hole <$> holeLit

431

401

432−parsePropertyUpdate :: TokenParser (PSString, Expr)

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

433parsePropertyUpdate = do

403parsePropertyUpdate = do

434 name <- parseLabel

404 name <- parseLabel

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

435− _ <- C.indented *> equals

406+ _ <- indented *> equals

436− value <- C.indented *> parseValue

407+ value <- indented *> parseValue

437− return (name, value)

408+ return (name :| rest, value)

438

409

439parseAccessor :: Expr -> TokenParser Expr

410parseAccessor :: Expr -> TokenParser Expr

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

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

441−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj

412+parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj

442

413

443parseDo :: TokenParser Expr

414parseDo :: TokenParser Expr

444parseDo = do

415parseDo = do

445 reserved "do"

416 reserved "do"

446− C.indented

417+ indented

447− Do <$> C.mark (P.many1 (C.same *> C.mark parseDoNotationElement))

418+ Do <$> mark (P.many1 (same *> mark parseDoNotationElement))

448

419

449parseDoNotationLet :: TokenParser DoNotationElement

420parseDoNotationLet :: TokenParser DoNotationElement

450−parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))

421+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration)))

451

422

452parseDoNotationBind :: TokenParser DoNotationElement

423parseDoNotationBind :: TokenParser DoNotationElement

453−parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue

424+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue

454

425

455parseDoNotationElement :: TokenParser DoNotationElement

426parseDoNotationElement :: TokenParser DoNotationElement

456parseDoNotationElement = P.choice

427parseDoNotationElement = P.choice

@@ -461,33 +432,34 @@ parseDoNotationElement = P.choice

461

432

462-- | Expressions including indexers and record updates

433-- | Expressions including indexers and record updates

463indexersAndAccessors :: TokenParser Expr

434indexersAndAccessors :: TokenParser Expr

464−indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

435+indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom

465 where

436 where

466 postfixTable = [ parseAccessor

437 postfixTable = [ parseAccessor

467 , P.try . parseUpdaterBody

438 , P.try . parseUpdaterBody

468 ]

439 ]

469

440

470−-- |

441+-- | Parse an expression

471−-- Parse a value

472−--

473parseValue :: TokenParser Expr

442parseValue :: TokenParser Expr

474parseValue = withSourceSpan PositionedValue

443parseValue = withSourceSpan PositionedValue

475 (P.buildExpressionParser operators

444 (P.buildExpressionParser operators

476− . C.buildPostfixParser postfixTable

445+ . buildPostfixParser postfixTable

477 $ indexersAndAccessors) P.<?> "expression"

446 $ indexersAndAccessors) P.<?> "expression"

478 where

447 where

479− postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

448+ postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v

480− , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v

449+ , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v

481 ]

450 ]

482− operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)

451+ operators = [ [ P.Prefix (indented *> symbol' "-" *> return UnaryMinus)

483 ]

452 ]

484− , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

453+ , [ P.Infix (P.try (indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

485 return (BinaryNoParens ident)) P.AssocRight

454 return (BinaryNoParens ident)) P.AssocRight

486 ]

455 ]

487 ]

456 ]

488

457

489parseUpdaterBody :: Expr -> TokenParser Expr

458parseUpdaterBody :: Expr -> TokenParser Expr

490−parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

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

460+ where

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

462+ | otherwise = ObjectUpdateNested v xs

491

463

492parseAnonymousArgument :: TokenParser Expr

464parseAnonymousArgument :: TokenParser Expr

493parseAnonymousArgument = underscore *> pure AnonymousArgument

465parseAnonymousArgument = underscore *> pure AnonymousArgument

@@ -501,21 +473,21 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

501 <|> return id

473 <|> return id

502

474

503parseNullaryConstructorBinder :: TokenParser Binder

475parseNullaryConstructorBinder :: TokenParser Binder

504−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []

476+parseNullaryConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> pure []

505

477

506parseConstructorBinder :: TokenParser Binder

478parseConstructorBinder :: TokenParser Binder

507−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)

479+parseConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> many (indented *> parseBinderNoParens)

508

480

509parseObjectBinder:: TokenParser Binder

481parseObjectBinder:: TokenParser Binder

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

482+parseObjectBinder = LiteralBinder <$> parseObjectLiteral (indented *> parseIdentifierAndBinder)

511

483

512parseArrayBinder :: TokenParser Binder

484parseArrayBinder :: TokenParser Binder

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

485+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder)

514

486

515parseVarOrNamedBinder :: TokenParser Binder

487parseVarOrNamedBinder :: TokenParser Binder

516parseVarOrNamedBinder = do

488parseVarOrNamedBinder = do

517− name <- C.parseIdent

489+ name <- parseIdent

518− let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)

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

519 parseNamedBinder <|> return (VarBinder name)

491 parseNamedBinder <|> return (VarBinder name)

520

492

521parseNullBinder :: TokenParser Binder

493parseNullBinder :: TokenParser Binder

@@ -528,11 +500,9 @@ parseIdentifierAndBinder =

528 return (mkString name, b)

500 return (mkString name, b)

529 <|> (,) <$> stringLiteral <*> rest

501 <|> (,) <$> stringLiteral <*> rest

530 where

502 where

531− rest = C.indented *> colon *> C.indented *> parseBinder

503+ rest = indented *> colon *> indented *> parseBinder

532

504

533−-- |

534−-- Parse a binder

505+-- | Parse a binder

535−--

536parseBinder :: TokenParser Binder

506parseBinder :: TokenParser Binder

537parseBinder =

507parseBinder =

538 withSourceSpan

508 withSourceSpan

@@ -543,7 +513,7 @@ parseBinder =

543 )

513 )

544 where

514 where

545 operators =

515 operators =

546− [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

516+ [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

547 return (BinaryNoParensBinder op)) P.AssocRight

517 return (BinaryNoParensBinder op)) P.AssocRight

548 ]

518 ]

549 ]

519 ]

@@ -569,9 +539,7 @@ parseBinderAtom = P.choice

569 , ParensInBinder <$> parens parseBinder

539 , ParensInBinder <$> parens parseBinder

570 ] P.<?> "binder"

540 ] P.<?> "binder"

571

541

572−-- |

573−-- Parse a binder as it would appear in a top level declaration

542+-- | Parse a binder as it would appear in a top level declaration

574−--

575parseBinderNoParens :: TokenParser Binder

543parseBinderNoParens :: TokenParser Binder

576parseBinderNoParens = P.choice

544parseBinderNoParens = P.choice

577 [ parseNullBinder

545 [ parseNullBinder

@@ -586,8 +554,6 @@ parseBinderNoParens = P.choice

586 , ParensInBinder <$> parens parseBinder

554 , ParensInBinder <$> parens parseBinder

587 ] P.<?> "binder"

555 ] P.<?> "binder"

588

556

589−-- |

590−-- Parse a guard

557+-- | Parse a guard

591−--

592parseGuard :: TokenParser Guard

558parseGuard :: TokenParser Guard

593−parseGuard = pipe *> C.indented *> parseValue

559+parseGuard = pipe *> indented *> parseValue

src/Language/PureScript/Pretty/JS.hs+7−5

@@ -159,11 +159,13 @@ conditional = mkPattern match

159 match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

160 match _ = Nothing

161

162−accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

162+accessor :: Pattern PrinterState JS (Text, JS)

163accessor = mkPattern match

164 where

165− -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513

165+ match (JSIndexer _ (JSStringLiteral _ prop) val) =

166− match (JSAccessor _ prop val) = Just (emit prop, val)

166+ case decodeString prop of

167+ Just s | not (identNeedsEscaping s) -> Just (s, val)

168+ _ -> Nothing

167 match _ = Nothing

169 match _ = Nothing

168

170

169indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

171indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

@@ -257,8 +259,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

257 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

259 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

258 operators :: (Emit gen) => OperatorTable PrinterState JS gen

260 operators :: (Emit gen) => OperatorTable PrinterState JS gen

259 operators =

261 operators =

260− OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]

262+ OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

261− , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

263+ , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]

262 , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

264 , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

263 , [ unary JSNew "new " ]

265 , [ unary JSNew "new " ]

264 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

266 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

src/Language/PureScript/Pretty/Values.hs+11−1

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

12import Control.Arrow (second)

13

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

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

15

16

16import qualified Data.Text as T

17import qualified Data.Text as T

17import Data.Text (Text)

18import Data.Text (Text)

@@ -47,6 +48,12 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

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

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

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

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

49

50

51+prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, 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

56+

50-- | Pretty-print an expression

57-- | Pretty-print an expression

51prettyPrintValue :: Int -> Expr -> Box

58prettyPrintValue :: Int -> Expr -> Box

52prettyPrintValue d _ | d < 0 = text "..."

59prettyPrintValue d _ | d < 0 = text "..."

@@ -56,7 +63,10 @@ prettyPrintValue d (IfThenElse cond th el) =

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

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

57 ])

64 ])

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

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

59−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (prettyPrintObjectKey key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps

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

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

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

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

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

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

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

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

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

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

src/Language/PureScript/Publish.hs+14−27

@@ -16,30 +16,23 @@ module Language.PureScript.Publish

16 , checkCleanWorkingTree

17 , getVersionFromGitTag

18 , getBowerRepositoryInfo

19− , getModulesAndBookmarks

19+ , getModules

20 , getResolvedDependencies

21 ) where

22

23−import Prelude ()

23+import Protolude hiding (stdin)

24−import Prelude.Compat hiding (userError)

25

24

26−import Control.Arrow ((***), first)

25+import Control.Arrow ((***))

27import Control.Category ((>>>))

26import Control.Category ((>>>))

28−import Control.Exception (catch, try)

29−import Control.Monad.Error.Class (MonadError(..))

30−import Control.Monad.Trans.Except

31import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

27import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

32−import Control.Monad.Writer.Strict

28+import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)

33

29

34import Data.Aeson.BetterErrors

30import Data.Aeson.BetterErrors

35import Data.Char (isSpace)

31import Data.Char (isSpace)

36−import Data.Foldable (traverse_)

32+import Data.String (String, lines)

37−import Data.Function (on)

38import Data.List (stripPrefix, (\\), nubBy)

33import Data.List (stripPrefix, (\\), nubBy)

39import Data.List.NonEmpty (NonEmpty(..))

34import Data.List.NonEmpty (NonEmpty(..))

40import Data.List.Split (splitOn)

35import Data.List.Split (splitOn)

41−import Data.Maybe

42−import Data.Text (Text)

43import qualified Data.Text as T

36import qualified Data.Text as T

44import qualified Data.Text.Lazy as TL

37import qualified Data.Text.Lazy as TL

45import qualified Data.Text.Lazy.Encoding as TL

38import qualified Data.Text.Lazy.Encoding as TL

@@ -47,10 +40,7 @@ import Data.Time.Clock (UTCTime)

47import Data.Version

40import Data.Version

48import qualified Data.SPDX as SPDX

41import qualified Data.SPDX as SPDX

49

42

50−import Safe (headMay)

51−

52import System.Directory (doesFileExist, findExecutable)

43import System.Directory (doesFileExist, findExecutable)

53−import System.Exit (exitFailure)

54import System.FilePath (pathSeparator)

44import System.FilePath (pathSeparator)

55import System.Process (readProcess)

45import System.Process (readProcess)

56import qualified System.FilePath.Glob as Glob

46import qualified System.FilePath.Glob as Glob

@@ -61,7 +51,7 @@ import qualified Web.Bower.PackageMeta as Bower

61

51

62import Language.PureScript.Publish.ErrorsWarnings

52import Language.PureScript.Publish.ErrorsWarnings

63import Language.PureScript.Publish.Utils

53import Language.PureScript.Publish.Utils

64−import qualified Language.PureScript as P (version)

54+import qualified Language.PureScript as P (version, ModuleName)

65import qualified Language.PureScript.Docs as D

55import qualified Language.PureScript.Docs as D

66

56

67data PublishOptions = PublishOptions

57data PublishOptions = PublishOptions

@@ -129,9 +119,6 @@ otherError = throwError . OtherError

129catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b

119catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b

130catchLeft a f = either f pure a

120catchLeft a f = either f pure a

131

121

132−unlessM :: Monad m => m Bool -> m () -> m ()

133−unlessM cond act = cond >>= flip unless act

134−

135preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage

122preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage

136preparePackage' opts = do

123preparePackage' opts = do

137 unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)

124 unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)

@@ -144,7 +131,7 @@ preparePackage' opts = do

144 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

131 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

145 pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag

132 pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag

146 pkgGithub <- getBowerRepositoryInfo pkgMeta

133 pkgGithub <- getBowerRepositoryInfo pkgMeta

147− (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

134+ (pkgModules, pkgModuleMap) <- getModules

148

135

149 let declaredDeps = map fst (bowerDependencies pkgMeta ++

136 let declaredDeps = map fst (bowerDependencies pkgMeta ++

150 bowerDevDependencies pkgMeta)

137 bowerDevDependencies pkgMeta)

@@ -155,18 +142,18 @@ preparePackage' opts = do

155

142

156 return D.Package{..}

143 return D.Package{..}

157

144

158−getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

145+getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName)

159−getModulesAndBookmarks = do

146+getModules = do

160 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

147 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

161− (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles

148+ (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles

162

149

163− case runExcept (D.convertModulesInPackage modules') of

150+ case runExcept (D.convertModulesInPackage modules' moduleMap) of

164− Right modules -> return (bookmarks, modules)

151+ Right modules -> return (modules, moduleMap)

165 Left err -> userError (CompileError err)

152 Left err -> userError (CompileError err)

166

153

167 where

154 where

168− parseAndBookmark inputFiles depsFiles = do

155+ parseFilesInPackages inputFiles depsFiles = do

169− r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles

156+ r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles

170 case r of

157 case r of

171 Right r' ->

158 Right r' ->

172 return r'

159 return r'

src/Language/PureScript/Sugar/ObjectWildcards.hs+99−16

@@ -3,19 +3,48 @@ module Language.PureScript.Sugar.ObjectWildcards

3 , desugarDecl

4 ) where

5

6−import Prelude.Compat

6+import Prelude.Compat

7

8−import Control.Monad (forM)

8+import Control.Monad (forM, foldM)

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

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

10−import Control.Monad.Supply.Class

10+import Control.Monad.Supply.Class

11+import Data.List (partition)

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

13+import Data.Map (Map)

14+import qualified Data.Map as M

15+import Data.Maybe (catMaybes)

16+import Language.PureScript.AST

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

18+import Language.PureScript.Errors

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

20+import Language.PureScript.Names

21+import Language.PureScript.PSString (PSString)

11

22

12−import Data.List (partition)

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

13−import Data.Maybe (catMaybes)

24+-- For an update such as:

14−

25+--

15−import Language.PureScript.AST

26+-- x { foo = 0

16−import Language.PureScript.Errors

27+-- , bar.baz = 1

17−import Language.PureScript.Names

28+-- , bar.qux = 2 }

18−import Language.PureScript.PSString (PSString)

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

19

48

20desugarObjectConstructors

49desugarObjectConstructors

21 :: forall m

50 :: forall m

@@ -46,6 +75,7 @@ desugarDecl other = fn other

46 obj <- freshIdent'

75 obj <- freshIdent'

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

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

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

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

78+ desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

49 desugarExpr (Accessor prop u)

79 desugarExpr (Accessor prop u)

50 | Just props <- peelAnonAccessorChain u = do

80 | Just props <- peelAnonAccessorChain u = do

51 arg <- freshIdent'

81 arg <- freshIdent'

@@ -62,14 +92,67 @@ desugarDecl other = fn other

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

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

63 desugarExpr e = return e

93 desugarExpr e = return e

64

94

65− wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr

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

96+ transformNestedUpdate obj ps = do

97+ -- 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.

99+ val <- freshIdent'

100+ if isAnonymousArgument obj

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

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

103+ where

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

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

106+

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.

133+ buildUpdates :: Expr -> PathTree -> Expr

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

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

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

137+ goLayer path (key, Branch branch) =

138+ let path' = path ++ [key]

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

140+ accessor = foldr Accessor val path'

141+ objectUpdate = ObjectUpdate accessor updates

142+ in (key, objectUpdate)

143+

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

66− wrapLambda mkVal ps =

145+ wrapLambdaM mkVal ps =

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

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

68 in if null args

147 in if null args

69− then return $ mkVal props

148+ then mkVal props

70 else do

149 else do

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

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

151+ val <- mkVal ps'

72− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

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

153+

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

155+ wrapLambda mkVal = wrapLambdaM (return . mkVal)

73

156

74 stripPositionInfo :: Expr -> Expr

157 stripPositionInfo :: Expr -> Expr

75 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

@@ -86,7 +169,7 @@ desugarDecl other = fn other

86 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

87 isAnonymousArgument _ = False

170 isAnonymousArgument _ = False

88

171

89− mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))

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

90 mkProp (name, e) = do

173 mkProp (name, e) = do

91 arg <- freshIfAnon e

174 arg <- freshIfAnon e

92 return (arg, (name, maybe e argToExpr arg))

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

src/Language/PureScript/TypeChecker.hs+8

@@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go

297 case M.lookup className (typeClasses env) of

298 Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"

299 Just typeClass -> do

300+ checkInstanceArity dictName className typeClass tys

300 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301 checkOrphanInstance dictName className typeClass tys

302 checkOrphanInstance dictName className typeClass tys

302 _ <- traverseTypeInstanceBody checkInstanceMembers body

303 _ <- traverseTypeInstanceBody checkInstanceMembers body

@@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go

306 go (PositionedDeclaration pos com d) =

307 go (PositionedDeclaration pos com d) =

307 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

308 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

308

309

310+ checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()

311+ checkInstanceArity dictName className typeClass tys = do

312+ let typeClassArity = length (typeClassArguments typeClass)

313+ instanceArity = length tys

314+ when (typeClassArity /= instanceArity) $

315+ throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity

316+

309 checkInstanceMembers :: [Declaration] -> m [Declaration]

317 checkInstanceMembers :: [Declaration] -> m [Declaration]

310 checkInstanceMembers instDecls = do

318 checkInstanceMembers instDecls = do

311 let idents = sort . map head . group . map memberName $ instDecls

319 let idents = sort . map head . group . map memberName $ instDecls

src/Language/PureScript/TypeChecker/Entailment.hs+14−6

@@ -45,6 +45,8 @@ import qualified Language.PureScript.Constants as C

45data Evidence

46 = NamedInstance (Qualified Ident)

47 -- ^ An existing named instance

48+ | WarnInstance Type

49+ -- ^ Computed instance of the Warn type class with a user-defined warning message

48 | IsSymbolInstance PSString

50 | IsSymbolInstance PSString

49 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

51 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

50 | CompareSymbolInstance

52 | CompareSymbolInstance

@@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints =

144 solve constraint

146 solve constraint

145 where

147 where

146 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

148 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

149+ forClassName _ C.Warn [msg] =

150+ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]

147 forClassName _ C.IsSymbol [TypeLevelString sym] =

151 forClassName _ C.IsSymbol [TypeLevelString sym] =

148 [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

152 [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

149 forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

153 forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

@@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints =

216 let subst'' = fmap (substituteType currentSubst') subst'

220 let subst'' = fmap (substituteType currentSubst') subst'

217 -- Solve any necessary subgoals

221 -- Solve any necessary subgoals

218 args <- solveSubgoals subst'' (tcdDependencies tcd)

222 args <- solveSubgoals subst'' (tcdDependencies tcd)

223+ initDict <- lift . lift $ mkDictionary (tcdValue tcd) args

219 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

224 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

220− (mkDictionary (tcdValue tcd) args)

225+ initDict

221 (tcdPath tcd)

226 (tcdPath tcd)

222 return match

227 return match

223 Unsolved unsolved -> do

228 Unsolved unsolved -> do

@@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints =

308 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

313 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

309

314

310 -- Make a dictionary from subgoal dictionaries by applying the correct function

315 -- Make a dictionary from subgoal dictionaries by applying the correct function

311− mkDictionary :: Evidence -> Maybe [Expr] -> Expr

316+ mkDictionary :: Evidence -> Maybe [Expr] -> m Expr

312− mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

317+ mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args)

318+ mkDictionary (WarnInstance msg) _ = do

319+ tell . errorMessage $ UserDefinedWarning msg

320+ return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral []))

313 mkDictionary (IsSymbolInstance sym) _ =

321 mkDictionary (IsSymbolInstance sym) _ =

314 let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in

322 let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in

315− TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))

323+ return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))

316 mkDictionary CompareSymbolInstance _ =

324 mkDictionary CompareSymbolInstance _ =

317− TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

325+ return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

318 mkDictionary AppendSymbolInstance _ =

326 mkDictionary AppendSymbolInstance _ =

319− TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

327+ return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

320

328

321 -- Turn a DictionaryValue into a Expr

329 -- Turn a DictionaryValue into a Expr

322 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

330 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

src/Language/PureScript/TypeChecker/Types.hs+18−12

@@ -77,11 +77,11 @@ typesOf

77 -> [(Ident, Expr)]

78 -> m [(Ident, (Expr, Type))]

79typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

80− tys <- capturingSubstitution tidyUp $ do

80+ (tys, wInfer) <- capturingSubstitution tidyUp $ do

81− SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals

81+ (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals

82 ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict

83 ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict

84− return (map (False, ) ds1 ++ map (True, ) ds2)

84+ return (map (False, ) ds1 ++ map (True, ) ds2, w)

85

86 inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do

87 -- Replace type class dictionary placeholders with actual dictionaries

@@ -123,10 +123,13 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

123 -- Show warnings here, since types in wildcards might have been solved during

124 -- instance resolution (by functional dependencies).

125 finalState <- get

126+ let replaceTypes' = replaceTypes (checkSubstitution finalState)

127+ runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState

128+ raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w

129+

130+ raisePreviousWarnings False wInfer

126 forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do

131 forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do

127− let replaceTypes' = replaceTypes (checkSubstitution finalState)

132+ raisePreviousWarnings shouldGeneralize w

128− runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState

129− (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w

130

133

131 return (map fst inferred)

134 return (map fst inferred)

132 where

135 where

@@ -160,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

160 constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)

163 constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)

161

164

162 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

165 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

163− tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts

166+ tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts

164

167

165 isHoleError :: ErrorMessage -> Bool

168 isHoleError :: ErrorMessage -> Bool

166 isHoleError (ErrorMessage _ HoleInferredType{}) = True

169 isHoleError (ErrorMessage _ HoleInferredType{}) = True

@@ -187,7 +190,7 @@ data SplitBindingGroup = SplitBindingGroup

187-- This function also generates fresh unification variables for the types of

190-- This function also generates fresh unification variables for the types of

188-- declarations without type annotations, returned in the 'UntypedData' structure.

191-- declarations without type annotations, returned in the 'UntypedData' structure.

189typeDictionaryForBindingGroup

192typeDictionaryForBindingGroup

190− :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

193+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)

191 => Maybe ModuleName

194 => Maybe ModuleName

192 -> [(Ident, Expr)]

195 -> [(Ident, Expr)]

193 -> m SplitBindingGroup

196 -> m SplitBindingGroup

@@ -197,7 +200,7 @@ typeDictionaryForBindingGroup moduleName vals = do

197 -- fully expanded types.

200 -- fully expanded types.

198 let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)

201 let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)

199 (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do

202 (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do

200− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

203+ ty' <- replaceTypeWildcards ty

201 return ((ident, ty'), (ident, (expr, ty', checkType)))

204 return ((ident, ty'), (ident, (expr, ty', checkType)))

202 -- Create fresh unification variables for the types of untyped declarations

205 -- Create fresh unification variables for the types of untyped declarations

203 (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do

206 (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do

@@ -233,11 +236,14 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do

233 -- Kind check

236 -- Kind check

234 (kind, args) <- kindOfWithScopedVars ty

237 (kind, args) <- kindOfWithScopedVars ty

235 checkTypeKind ty kind

238 checkTypeKind ty kind

239+ -- We replace type synonyms _after_ kind-checking, since we don't want type

240+ -- synonym expansion to bring type variables into scope. See #2542.

241+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

236 -- Check the type with the new names in scope

242 -- Check the type with the new names in scope

237 val' <- if checkType

243 val' <- if checkType

238− then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty

244+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty'

239− else return (TypedValue False val ty)

245+ else return (TypedValue False val ty')

240− return (ident, (val', ty))

246+ return (ident, (val', ty'))

241

247

242-- | Infer a type for a value in a binding group which lacks an annotation.

248-- | Infer a type for a value in a binding group which lacks an annotation.

243typeForBindingGroupElement

249typeForBindingGroupElement

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

@@ -243,7 +243,7 @@ unwrapResult = withObject "result" $ \o -> do

243 case rt of

244 "error" -> do

245 res <- o .: "result"

246− pure (Left res)

246+ withArray "errors" (fmap (Left . fold) . traverse (withObject "error" (.: "message"))) res

247 "success" -> do

248 res <- o .: "result"

249 pure (Right res)