f49130b · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'pure11/pure11' into native

commitf49130b2efecacb8d42a6da3e77e2918a487515d authorAndy Arvanitis <andyarvanitis@gmail.com> dateMon 23 Jan 2017, 23:38 (10 years ago) parente1c490b 3b48ac7

61 files changed+1692−1264

compare with golang

unifiedsplit

examples/failing/2542.pursnew file+9

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

1+-- @shouldFailWith UndefinedTypeVariable

2+module Main where

4+type T = forall a. Array a

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

22module Main where

44import M1

examples/failing/MPTCs.purs+1−1

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

1−-- @shouldFailWith KindsDoNotUnify

1+-- @shouldFailWith ClassInstanceArityMismatch

22module Main where

44import Prelude

examples/failing/TooFewClassInstanceArgs.pursnew file+8

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

1+-- @shouldFailWith ClassInstanceArityMismatch

2+module Main where

4+import Prelude

6+class Foo a b

8+instance fooString :: Foo String

examples/passing/2136.pursnew file+9

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

1+module Main where

3+import Prelude

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

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

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

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

3+import Prelude

4+import Control.Monad.Eff.Console

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

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

3+import Prelude

4+import Control.Monad.Eff.Console

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

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

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

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

5+data X = X

7+f a@X X = a

9+main = log "Done"

examples/warning/2542.pursnew file+16

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

1+-- @shouldWarnWith MissingTypeDeclaration

2+module Main where

4+import Control.Monad.Eff.Console

6+type T = forall a. Array a

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

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

5+foo x = x

7+bar :: Int

8+bar = foo 42

pcc/support/psc-package.json+1−1

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

11{

22 "name": "Main",

3− "set": "psc-0.10.5",

3+ "set": "master",

44 "source": "https://github.com/pure11/package-sets.git",

55 "depends": [

66 "console",

psc-docs/Main.hs+2−2

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

6060 Etags -> dumpTags input dumpEtags

6161 Ctags -> dumpTags input dumpCtags

6262 Markdown -> do

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

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

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

64+ >>= uncurry D.convertModulesInPackage)

6565 >>= successOrExit

6666

6767 case output of

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

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

130130 where

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

132132 loop sock = do

133− accepted <- runExceptT $ acceptCommand sock

133+ accepted <- runExceptT (acceptCommand sock)

134134 case accepted of

135− Left err -> $(logDebug) err

135+ Left err -> $(logError) err

136136 Right (cmd, h) -> do

137137 case decodeT cmd of

138138 Just cmd' -> do

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

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

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

149149 Nothing -> do

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

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

151151 liftIO $ do

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

153153 hFlush stdout

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

167167 case cmd' of

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

169169 Just cmd -> do

170− $(logDebug) cmd

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

171171 pure (cmd, h)

172172 where

173173 acceptConnection = liftIO $ do

purescript.cabal+5−2

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

128128 containers -any,

129129 clock -any,

130130 data-ordlist >= 0.4.7.0,

131+ deepseq -any,

131132 directory >= 1.2,

132133 dlist -any,

133134 edit-distance -any,

@@ -204,6 +205,7 @@ library

204205 Language.PureScript.CodeGen.Cpp.Optimizer.TCO

205206 Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry

206207 Language.PureScript.CodeGen.Cpp.Optimizer.Unused

208+ Language.PureScript.CodeGen.Cpp.Recursion

207209 Language.PureScript.CodeGen.Cpp.Types

208210 Language.PureScript.CodeGen.Cpp.Unicode

209211 Language.PureScript.Pretty.Cpp

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

288290 Language.PureScript.Docs.Types

289291 Language.PureScript.Docs.RenderedCode

290292 Language.PureScript.Docs.RenderedCode.Types

291− Language.PureScript.Docs.RenderedCode.Render

293+ Language.PureScript.Docs.RenderedCode.RenderType

294+ Language.PureScript.Docs.RenderedCode.RenderKind

292295 Language.PureScript.Docs.AsMarkdown

293− Language.PureScript.Docs.ParseAndBookmark

296+ Language.PureScript.Docs.ParseInPackage

294297 Language.PureScript.Docs.Utils.MonoidExtras

295298

296299 Language.PureScript.Publish

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

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

1212import Data.Aeson.TH

1313import qualified Data.Map as M

1414import Data.Text (Text)

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

1516

1617import Language.PureScript.AST.Binders

1718import Language.PureScript.AST.Literals

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

4344

4445-- | A type of error messages

4546data SimpleErrorMessage

46− = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

47+ = ModuleNotFound ModuleName

48+ | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

4749 | ErrorParsingModule P.ParseError

4850 | MissingFFIModule ModuleName

4951 | MultipleFFIModules ModuleName [FilePath]

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

134136 | CaseBinderLengthDiffers Int [Binder]

135137 | IncorrectAnonymousArgument

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

137− | DeprecatedRequirePath

138139 | CannotGeneralizeRecursiveFunction Ident Type

139140 | CannotDeriveNewtypeForData (ProperName 'TypeName)

140141 | ExpectedWildcard (ProperName 'TypeName)

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

142147 deriving (Show)

143148

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

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

582587 --

583588 | ObjectUpdate Expr [(PSString, Expr)]

584589 -- |

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

585595 -- Function introduction

586596 --

587597 | Abs (Either Ident Binder) Expr

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

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

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

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

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

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

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

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

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

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

117118 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

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

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

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

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

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

184186 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

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

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

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

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

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

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

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

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

259263 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'

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

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

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

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

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

336341 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

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

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

412417 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

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

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

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

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

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

502508 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

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

504511 let s' = S.insert name s

505512 in g'' s' v1

src/Language/PureScript/CodeGen/Cpp.hs+10−108

@@ -32,23 +32,22 @@ import Data.Char (isLetter)

3232import Data.Function (on)

3333import Data.List

3434import qualified Data.Map as M

35−import Data.Maybe (catMaybes, fromJust)

35+import Data.Maybe (catMaybes)

3636import Data.Monoid ((<>))

3737import Data.Text (Text, unpack)

3838import qualified Data.Text as Text

3939

4040import Control.Monad (forM, replicateM)

41−import Control.Monad.Reader (MonadReader, ask)

41+import Control.Monad.Reader (MonadReader)

4242import Control.Monad.Supply.Class

4343import Language.PureScript.AST.SourcePos

4444import Language.PureScript.CodeGen.Cpp.AST as AST

4545import Language.PureScript.CodeGen.Cpp.Common as Common

4646import Language.PureScript.CodeGen.Cpp.File

4747import Language.PureScript.CodeGen.Cpp.Optimizer

48−import Language.PureScript.CodeGen.Cpp.Optimizer.TCO

48+import Language.PureScript.CodeGen.Cpp.Recursion

4949import Language.PureScript.CodeGen.Cpp.Types

5050import Language.PureScript.CodeGen.Cpp.Unicode

51−import Language.PureScript.Comments

5251import Language.PureScript.CoreFn

5352import Language.PureScript.Names

5453import Language.PureScript.Options

@@ -93,7 +92,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

9392 E.dataConstructors env

9493 cpps' <- traverse (optimize $ namesmap ++ datamap) cpps

9594 foreignWrappers <- curriedForeigns

96− let optimized = (otherTransforms otherOpts <$> cpps') ++ foreignWrappers

95+ let optimized = (otherTransforms otherOpts . convertRecursiveLets <$> cpps') ++ foreignWrappers

9796 let moduleHeader =

9897 fileBegin mn "HH" ++

9998 P.linebreak ++

@@ -333,7 +332,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

333332 fnToLambda (CppFunction name args _ qs body) =

334333 CppVariableIntroduction

335334 (name, Just $ Any [Const])

336− (filter (== Static) qs)

335+ qs -- (filter (== Static) qs)

337336 (Just $ CppLambda cs args (Just $ Any []) body)

338337 where

339338 cs

@@ -350,82 +349,6 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

350349 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f

351350 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body

352351 go cpp = cpp

353− -------------------------------------------------------------------------------------------------

354− convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]

355− -------------------------------------------------------------------------------------------------

356− convertRecursiveFns cpps otherCpp

357− | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'

358− where

359− cpps' = everywhereOnCpp removeRec <$> cpps

360− allCpps = CppBlock $ otherCpp : cpps'

361− fns :: [(Text, Cpp)]

362− fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps

363− filteredFns :: Cpp -> [(Text, Cpp)]

364− filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns

365− recursive :: Cpp -> [Cpp]

366− recursive cpp'@(CppFunction _ _ _ qs _)

367− | Recursive `elem` qs = [cpp']

368− recursive cpp'@(CppVariableIntroduction _ qs _)

369− | Recursive `elem` qs = [cpp']

370− recursive _ = []

371− removeRec :: Cpp -> Cpp

372− removeRec (CppFunction _ _ _ qs _)

373− | Recursive `elem` qs = CppNoOp

374− removeRec (CppVariableIntroduction _ qs _)

375− | Recursive `elem` qs = CppNoOp

376− removeRec cpp' = cpp'

377− replaceVar :: [(Text, Cpp)] -> Cpp -> Cpp

378− replaceVar rs = go

379− where

380− go (CppVar var)

381− | Just var' <- lookup var rs = var'

382− go cpp' = cpp'

383− dict :: Cpp

384− dict =

385− CppVariableIntroduction

386− (topdict, Just $ Any [Const])

387− []

388− (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))

389− accessed :: Text -> Text -> (Text, Cpp)

390− accessed dictname name =

391− ( name

392− , CppApp

393− (CppDataGet

394− (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)

395− dict')

396− [dict'])

397− where

398− dict' = CppVar dictname

399− accessor :: Text -> (Text, Cpp) -> Cpp

400− accessor dictname (name, _) =

401− CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)

402− toelem :: Cpp -> (Text, Cpp)

403− toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =

404− ( name

405− , withdict . maybeRemCaps $

406− CppLambda

407− [CaptureAll]

408− args

409− rtyp

410− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))

411− toelem (CppVariableIntroduction (name, _) _ (Just body')) =

412− let replacements = accessed localdict . fst <$> filteredFns body'

413− replaced = everywhereOnCpp (replaceVar replacements) body'

414− in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])

415− toelem _ = error "not a function"

416− withdict :: Cpp -> Cpp

417− withdict cpp' =

418− maybeRemCaps $

419− CppLambda

420− [CaptureAll]

421− [(localdict, Just $ Any [Const, Ref])]

422− (Just $ Any [])

423− (returnBlock cpp')

424− topdict :: Text

425− topdict = "_$dict$_"

426− localdict :: Text

427− localdict = "$dict$"

428− convertRecursiveFns cpps _ = cpps

429352

430353 -- |

431354 -- Generate code in the simplified C++1x intermediate representation for a value or expression.

@@ -437,6 +360,9 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

437360 valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []

438361 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))

439362 | arity ty > 0 = return . curriedName' $ varToCpp ident

363+ valueToCpp (Var (_, _, Nothing, _) ident@(Qualified (Just _) _))

364+ | Just (ty, _, _) <- M.lookup ident (E.names env)

365+ , arity ty > 0 = return . curriedName' $ varToCpp ident

440366 valueToCpp (Var _ ident) = return $ varToCpp ident

441367 valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)

442368 valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)

@@ -500,32 +426,8 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

500426 valueToCpp (Let _ ds val) = do

501427 ds' <- concat <$> mapM (bindToCpp []) ds

502428 ret <- valueToCpp val

503− opts <- ask

504− let ds'' = tco opts <$> ds'

505− let rs =

506− if hasRecursion ds''

507− then convertRecursiveFns ds'' ret

508− else ds''

509− let cpps = innerLambdas <$> rs

510− return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []

511− where

512− hasRecursion :: [Cpp] -> Bool

513− hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'

514− where

515− valnames :: [Text]

516− valnames = concatMap (everythingOnCpp (++) valname) cpps'

517− valname :: Cpp -> [Text]

518− valname (CppFunction name _ _ _ _) = [name]

519− valname (CppVariableIntroduction (name, _) _ _) = [name]

520− valname _ = []

521− hasRecursiveRef :: Cpp -> Bool

522− hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body

523− hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value

524− hasRecursiveRef _ = False

525− ref :: Cpp -> Bool

526− ref (CppVar name)

527− | name `elem` valnames = True

528− ref _ = False

429+ let cpps = (innerLambdas <$> ds') ++ [CppReturn ret]

430+ return $ CppApp (CppLambda [] [] Nothing (CppBlock cpps)) []

529431 valueToCpp Constructor {} = return CppNoOp

530432

531433 -- |

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

@@ -67,7 +67,7 @@ optimize nm cpp = do

6767optimize' :: (MonadReader Options m, MonadSupply m) => NamesMap -> Cpp -> m Cpp

6868optimize' nm cpp = do

6969 opts <- ask

70− untilFixedPoint (liftM toAutoVars . inlineFnComposition . applyAll

70+ untilFixedPoint (liftM toAutoVars . inlineFnComposition . inlineUnsafePartial . applyAll

7171 [ collapseNestedBlocks

7272 , collapseCtorChecksToSwitch

7373 , collapseNestedIfs

src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hs+7−7

@@ -21,7 +21,7 @@ module Language.PureScript.CodeGen.Cpp.Optimizer.Blocks

2121 ) where

2222

2323import Prelude.Compat

24−import Data.Either

24+import Data.Maybe

2525

2626import Language.PureScript.CodeGen.Cpp.AST

2727import Language.PureScript.CodeGen.Cpp.Types

@@ -94,16 +94,16 @@ collapseCtorChecksToSwitch = everywhereOnCpp collapse

9494 collapse (CppBlock cpps@(_:_:_)) = CppBlock (go cpps)

9595 where

9696 go cpps'@(cpp:_)

97− | Right (lhs, _, _) <- fromif Nothing cpp

98− , (otherCpps, ifs@(_:_:_)) <- partitionEithers $ fromif (Just lhs) <$> cpps'

99− = CppSwitch lhs ((\(_,b,c) -> (b,c)) <$> ifs) Nothing : otherCpps

97+ | Just (lhs, _, _) <- fromif Nothing cpp

98+ , ifs@(_:_:_) <- catMaybes . takeWhile (isJust) $ fromif (Just lhs) <$> cpps'

99+ = CppSwitch lhs ((\(_,b,c) -> (b,c)) <$> ifs) Nothing : drop (length ifs) cpps'

100100 go (cpp':cpps') = cpp' : go cpps'

101101 go cpp' = cpp'

102− fromif :: Maybe Cpp -> Cpp -> Either Cpp (Cpp, Cpp, Cpp)

102+ fromif :: Maybe Cpp -> Cpp -> Maybe (Cpp, Cpp, Cpp)

103103 fromif cond (CppIfElse (CppBinary EqualTo lhs rhs) stmt Nothing)

104104 | CppApp (CppVar f) _ <- lhs

105105 , f == getCtor

106106 , maybe True (lhs==) cond

107− = Right (lhs, rhs, stmt)

108− fromif _ cpp = Left cpp

107+ = Just (lhs, rhs, stmt)

108+ fromif _ _ = Nothing

109109 collapse cpp = cpp

src/Language/PureScript/CodeGen/Cpp/Optimizer/Common.hs+1

@@ -41,6 +41,7 @@ isReassigned :: Text -> Cpp -> Bool

4141isReassigned var1 = everythingOnCpp (||) check

4242 where

4343 check :: Cpp -> Bool

44+ check (CppLambda _ args _ _) | var1 `elem` (map fst args) = True

4445 check (CppFunction _ args _ _ _) | var1 `elem` (map fst args) = True

4546 check (CppVariableIntroduction arg _ _) | var1 == fst arg = True

4647 check (CppAssignment (CppVar arg) _) | var1 == arg = True

src/Language/PureScript/CodeGen/Cpp/Optimizer/Inliner.hs+13−4

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

2121 , inlineOperator

2222 , inlineCommonOperators

2323 , inlineFnComposition

24+ , inlineUnsafePartial

2425 , etaConvert

2526 , unThunk

2627 , evaluateIifes

@@ -269,10 +270,9 @@ inlineCommonOperators = applyAll $

269270

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

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

272−inlineFnComposition :: (MonadSupply m) => Cpp -> m Cpp

273−inlineFnComposition = everywhereOnCppTopDownM convert

274− where

275− convert :: (MonadSupply m) => Cpp -> m Cpp

273+inlineFnComposition :: forall m. MonadSupply m => Cpp -> m Cpp

274+inlineFnComposition = everywhereOnCppTopDownM convert where

275+ convert :: Cpp -> m Cpp

276276 convert (CppApp fn [dict', x, y, z])

277277 | isFnCompose dict' fn = return $ CppApp x [CppApp y [z]]

278278 | isFnComposeFlipped dict' fn = return $ CppApp y [CppApp x [z]]

@@ -303,6 +303,15 @@ inlineFnComposition = everywhereOnCppTopDownM convert

303303 fnComposeFlipped :: (Text, Text)

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

305305

306+inlineUnsafePartial :: Cpp -> Cpp

307+inlineUnsafePartial = everywhereOnCppTopDown convert where

308+ convert (CppApp (CppAccessor (CppVar unsafePartial) (CppVar partialUnsafe)) [ comp ])

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

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

311+ -- if it is safe to do so

312+ = CppApp comp [ CppVar C.undefined ]

313+ convert other = other

314+

306315toAutoVars :: Cpp -> Cpp

307316toAutoVars = everywhereOnCpp convert

308317 where

src/Language/PureScript/CodeGen/Cpp/Optimizer/TCO.hs+35−31

@@ -48,10 +48,9 @@ tco' = everywhereOnCpp convert

4848 copyVar' (arg, t) = (copyVar arg, t)

4949

5050 convert :: Cpp -> Cpp

51−

52− convert cpp@(CppVariableIntroduction (name, ty) qs (Just fn@CppLambda {})) =

51+ convert cpp@(CppVariableIntroduction (name, ty) qs (Just lambda@CppLambda {})) =

5352 let

54− (argss, body', replace) = collectAllFunctionArgs [] id fn

53+ (argss, body', replace) = collectAllLambdaArgs [] id lambda

5554 in case () of

5655 _ | isTailCall name body' ->

5756 let

@@ -59,29 +58,34 @@ tco' = everywhereOnCpp convert

5958 in

6059 CppVariableIntroduction (name, ty) qs (Just (replace (toLoop name allArgs body')))

6160 | otherwise -> cpp

62−

63− convert fn@(CppFunction name (_:_) _ _ _) =

61+ convert cpp@(CppFunction name _ _ _ _) =

6462 let

65− (argss, body', replace) = collectAllFunctionArgs [] id fn

63+ (argss, body', replace) = collectAllFunctionArgs [] id cpp

6664 in case () of

6765 _ | isTailCall name body' ->

6866 let

6967 allArgs = fst <$> (concat $ reverse argss)

7068 in

7169 replace (toLoop name allArgs body')

72− | otherwise -> fn

73−

70+ | otherwise -> cpp

7471 convert cpp = cpp

7572

76− collectAllFunctionArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

77− collectAllFunctionArgs allArgs f (CppFunction ident args rty qs (CppBlock (body@(CppReturn _):_))) =

78− collectAllFunctionArgs (args : allArgs) (\b -> f (CppFunction ident (map copyVar' args) rty qs (CppBlock [b]))) body

79− collectAllFunctionArgs allArgs f (CppFunction ident args rty qs body@(CppBlock _)) =

80− (args : allArgs, body, f . CppFunction ident (map copyVar' args) rty qs)

81− collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty (CppBlock [body]))) =

82− collectAllFunctionArgs (args : allArgs) (\b -> f (CppReturn (CppLambda cs (map copyVar' args) rty (CppBlock [b])))) body

83− collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty body@(CppBlock _))) =

73+ collectAllLambdaArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

74+ collectAllLambdaArgs allArgs f (CppLambda cs args rty (CppBlock (body@(CppReturn _):_))) =

75+ collectAllLambdaArgs (args : allArgs) (\b -> f (CppLambda cs (map copyVar' args) rty (CppBlock [b]))) body

76+ collectAllLambdaArgs allArgs f (CppLambda cs args rty body@(CppBlock _)) =

77+ (args : allArgs, body, f . CppLambda cs (map copyVar' args) rty)

78+ collectAllLambdaArgs allArgs f (CppReturn (CppLambda cs args rty (CppBlock [body]))) =

79+ collectAllLambdaArgs (args : allArgs) (\b -> f (CppReturn (CppLambda cs (map copyVar' args) rty (CppBlock [b])))) body

80+ collectAllLambdaArgs allArgs f (CppReturn (CppLambda cs args rty body@(CppBlock _))) =

8481 (args : allArgs, body, f . CppReturn . CppLambda cs (map copyVar' args) rty)

82+ collectAllLambdaArgs allArgs f body = (allArgs, body, f)

83+

84+ collectAllFunctionArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

85+ collectAllFunctionArgs allArgs f (CppFunction name args rty qs (CppBlock (body@(CppReturn _):_))) =

86+ collectAllFunctionArgs (args : allArgs) (\b -> f (CppFunction name (map copyVar' args) rty qs (CppBlock [b]))) body

87+ collectAllFunctionArgs allArgs f (CppFunction name args rty qs body@(CppBlock _)) =

88+ (args : allArgs, body, f . CppFunction name (map copyVar' args) rty qs)

8589 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

8690

8791 isTailCall :: Text -> Cpp -> Bool

@@ -107,15 +111,26 @@ tco' = everywhereOnCpp convert

107111

108112 countSelfCallsUnderFunctions :: Cpp -> Int

109113 countSelfCallsUnderFunctions (CppFunction _ _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

110− countSelfCallsUnderFunctions (CppLambda _ (_:_) _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

114+ countSelfCallsUnderFunctions (CppLambda _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

111115 countSelfCallsUnderFunctions _ = 0

112116

113117 countSelfCallsWithFnArgs :: Cpp -> Int

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

118+ countSelfCallsWithFnArgs = go [] where

119+ go acc (CppVar ident')

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

121+ go acc (CppApp fn args) = go (args ++ acc) fn

122+ go _ _ = 0

123+

124+ hasFunction :: Cpp -> Bool

125+ hasFunction = Monoid.getAny . everythingOnCpp mappend (Monoid.Any . isFunction)

126+ where

127+ isFunction (CppFunction {}) = True

128+ isFunction (CppLambda {}) = True

129+ isFunction _ = False

115130

116131 toLoop :: Text -> [Text] -> Cpp -> Cpp

117132 toLoop ident allArgs cpp = CppBlock $

118− map (\arg -> CppVariableIntroduction (arg, Just $ Any []) [] (Just (CppVar (copyVar arg)))) allArgs ++

133+ map (\arg -> CppVariableIntroduction (arg, alwaysType (Auto [])) [] (Just (CppVar (copyVar arg)))) allArgs ++

119134 [ CppWhile (CppBooleanLiteral True) (CppBlock loop) ]

120135 where

121136 loop :: [Cpp]

@@ -129,7 +144,7 @@ tco' = everywhereOnCpp convert

129144 allArgumentValues = concat $ collectSelfCallArgs [] ret

130145 in

131146 CppBlock $ zipWith (\val arg ->

132− CppVariableIntroduction (tcoVar arg, Just $ Any [Const]) [] (Just val)) allArgumentValues allArgs

147+ CppVariableIntroduction (tcoVar arg, alwaysType (Auto [Const])) [] (Just val)) allArgumentValues allArgs

133148 ++ map (\arg ->

134149 CppAssignment (CppVar arg) (CppVar (tcoVar arg))) allArgs

135150 ++ [ CppContinue ]

@@ -142,14 +157,3 @@ tco' = everywhereOnCpp convert

142157 isSelfCall ident (CppApp (CppVar ident') _) = ident == ident'

143158 isSelfCall ident (CppApp fn _) = isSelfCall ident fn

144159 isSelfCall _ _ = False

145−

146− isSelfCallWithFnArgs :: Text -> Cpp -> [Cpp] -> Bool

147− isSelfCallWithFnArgs ident (CppVar ident') args | ident == ident' && any hasFunction args = True

148− isSelfCallWithFnArgs ident (CppApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

149− isSelfCallWithFnArgs _ _ _ = False

150−

151− hasFunction :: Cpp -> Bool

152− hasFunction = Monoid.getAny . everythingOnCpp mappend (Monoid.Any . isFunction)

153− where

154− isFunction (CppFunction {}) = True

155− isFunction _ = False

src/Language/PureScript/CodeGen/Cpp/Recursion.hsnew file+127

@@ -0,0 +1,127 @@

1+---------------------------------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.Cpp.Recursion

5+-- License : MIT

6+--

7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+--

12+---------------------------------------------------------------------------------------------------

13+{-# LANGUAGE PatternGuards #-}

14+

15+module Language.PureScript.CodeGen.Cpp.Recursion

16+ ( convertRecursiveLets

17+ ) where

18+

19+import Prelude.Compat

20+import Data.List

21+import Data.Maybe (fromJust)

22+import Data.Monoid ((<>))

23+import Data.Text (Text)

24+

25+import Language.PureScript.CodeGen.Cpp.AST as AST

26+import Language.PureScript.CodeGen.Cpp.File

27+import Language.PureScript.CodeGen.Cpp.Types

28+import Language.PureScript.Comments (Comment(..))

29+import qualified Language.PureScript.Pretty.Cpp as P

30+

31+-------------------------------------------------------------------------------------------------

32+convertRecursiveLets :: Cpp -> Cpp

33+-------------------------------------------------------------------------------------------------

34+convertRecursiveLets = everywhereOnCpp go

35+ where

36+ go :: Cpp -> Cpp

37+ go (CppFunction name args rty qs (CppBlock cpps)) =

38+ CppFunction name args rty qs (CppBlock (convertIfRecursive cpps))

39+ go (CppLambda cs args rty (CppBlock cpps)) =

40+ CppLambda cs args rty (CppBlock (convertIfRecursive cpps))

41+ go cpp = cpp

42+ convertIfRecursive :: [Cpp] -> [Cpp]

43+ convertIfRecursive cpps

44+ | names@(_:_) <- recNames cpps = convertRecursive names cpps

45+ where

46+ recNames :: [Cpp] -> [Text]

47+ recNames cpps' = nub $ concatMap (everythingOnCpp (++) recRefs) cpps'

48+ where

49+ recRefs :: Cpp -> [Text]

50+ recRefs (CppVariableIntroduction _ qs (Just cpp))

51+ | Recursive `elem` qs = everythingOnCpp (++) recRef cpp

52+ recRefs _ = []

53+ --

54+ recRef :: Cpp -> [Text]

55+ recRef (CppVar name') | name' `elem` possiblyRecNames = [name']

56+ recRef _ = []

57+ --

58+ possiblyRecNames :: [Text]

59+ possiblyRecNames = concatMap (everythingOnCpp (++) possiblyRecName) cpps'

60+ where

61+ possiblyRecName :: Cpp -> [Text]

62+ possiblyRecName (CppVariableIntroduction (name', _) qs (Just _))

63+ | Recursive `elem` qs = [name']

64+ possiblyRecName _ = []

65+ convertIfRecursive cpp = cpp

66+

67+-------------------------------------------------------------------------------------------------

68+convertRecursive :: [Text] -> [Cpp] -> [Cpp]

69+-------------------------------------------------------------------------------------------------

70+convertRecursive names cpps

71+ | not $ null lets

72+ = defines ++

73+ [letTable] ++

74+ (everywhereOnCpp remRecLet <$> cpps) ++

75+ undefines

76+ where

77+ tableName :: Text

78+ tableName = "let"

79+ --

80+ letTable :: Cpp

81+ letTable =

82+ CppVariableIntroduction

83+ (tableName, Just $ Any [Const])

84+ []

85+ (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> lets))

86+ --

87+ lets :: [(Text, Cpp)]

88+ lets = tableItem <$> concatMap (everythingOnCpp (++) recLet) cpps

89+ --

90+ recLet :: Cpp -> [Cpp]

91+ recLet cpp@(CppVariableIntroduction (name, _) _ (Just _))

92+ | name `elem` names = [cpp]

93+ recLet _ = []

94+ --

95+ remRecLet :: Cpp -> Cpp

96+ remRecLet (CppVariableIntroduction (name, _) _ (Just _))

97+ | name `elem` names = CppNoOp

98+ remRecLet cpp = cpp

99+ --

100+ tableItem :: Cpp -> (Text, Cpp)

101+ tableItem (CppVariableIntroduction (name, _) _ (Just body)) =

102+ (name, maybeRemCaps . addItemArg $ CppBlock [CppReturn body])

103+ where

104+ addItemArg :: Cpp -> Cpp

105+ addItemArg cpp = CppLambda [CaptureAll] [(tableName, constAnyRef)] (Just $ Any []) (CppBlock [CppReturn cpp])

106+ tableItem _ = error "not a variable introduction"

107+ --

108+ tableAccessor :: Text -> (Text, Cpp)

109+ tableAccessor name =

110+ ( name

111+ , CppApp

112+ (CppDataGet

113+ (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) lets)

114+ (CppVar tableName))

115+ [CppVar tableName])

116+ --

117+ defines :: [Cpp]

118+ defines = def . tableAccessor . fst <$> lets

119+ where

120+ def (name, cpp) = CppRaw $ "#define " <> name <> " " <> P.prettyPrintCpp1 cpp <> "#"

121+ --

122+ undefines :: [Cpp]

123+ undefines = undef . tableAccessor . fst <$> lets

124+ where

125+ undef (name, _) = CppRaw $ "#undef " <> name <> "#"

126+ --

127+convertRecursive _ cpps = cpps

src/Language/PureScript/CodeGen/Cpp/Types.hs+5−15

@@ -24,12 +24,6 @@ import Data.List

2424import Data.Monoid ((<>))

2525import Data.Text

2626

27−import Language.PureScript.CodeGen.Cpp.Common

28−import Language.PureScript.Names

29−import qualified Language.PureScript.Constants as C

30−

31−-- import Debug.Trace

32−

3327data CppType = Primitive Text | Auto [TypeQual] | Any [TypeQual]

3428 deriving (Show, Read, Eq)

3529

@@ -104,15 +98,6 @@ runValueQual TopLevel = ""

10498runCaptureType :: CaptureType -> Text

10599runCaptureType CaptureAll = "="

106100

107−-- TODO: move or remove this

108−--

109−qualifiedToStr :: ModuleName -> (a -> Ident) -> Qualified a -> Text

110−qualifiedToStr _ f (Qualified (Just (ModuleName [ProperName mn])) a)

111− | mn == C.prim = runIdent $ f a

112−qualifiedToStr m f (Qualified (Just m') a)

113− | m /= m' = moduleNameToCpp m' <> "::" <> identToCpp (f a)

114−qualifiedToStr _ f (Qualified _ a) = identToCpp (f a)

115−

116101boolType :: CppType

117102boolType = Primitive "bool"

118103

@@ -161,3 +146,8 @@ getCtor = dataNS <> "::ctor"

161146

162147constAnyRef :: Maybe CppType

163148constAnyRef = Just $ Any [Const, Ref]

149+

150+-- Prevents any optimization changes to type

151+--

152+alwaysType :: CppType -> Maybe CppType

153+alwaysType t = Just . Primitive $ runType t

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

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

3535 errorMessage, rethrowWithPosition, addHint)

3636import Language.PureScript.Names

3737import Language.PureScript.Options

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

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

3939import Language.PureScript.Traversals (sndM)

4040import qualified Language.PureScript.Constants as C

4141

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

6969 let standardExps = exps \\ foreignExps

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

7171 ++ 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']

7373

7474 where

7575

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

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

183183

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

191186

192187 -- |

193188 -- 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_ =

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

202197 maybe id rethrowWithPosition pos $ literalToValueJS l

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

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

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

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

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

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

207202 valueToJs' (Accessor _ prop val) =

208203 accessorString prop <$> valueToJs val

209204 valueToJs' (ObjectUpdate _ o ps) = do

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

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

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

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

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

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

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

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

267262 createFn =

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

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

270265 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

272267 ]

273268

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

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

299294 evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)

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

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

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

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

305300 extend = map stToAssign sts

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

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

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

358353 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

360355

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

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

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

397392 argVar <- freshName

398393 done'' <- go remain done'

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

401396 binderToJs' _ _ ConstructorBinder{} =

402397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

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

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

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

427422 literalToBinderJS varName done (ArrayLiteral bs) = do

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

430425 where

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

432427 go done' _ [] = return done'

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

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

159159 --

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

161161 -- |

162− -- An object property accessor expression

163− --

164− | JSAccessor (Maybe SourceSpan) Text JS

165− -- |

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

167163 --

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

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

259255 go (JSArrayLiteral _ js) = JSArrayLiteral ss js

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

261257 go (JSObjectLiteral _ js) = JSObjectLiteral ss js

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

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

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

265260 go (JSVar _ s) = JSVar ss s

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

293288 go (JSArrayLiteral ss _) = ss

294289 go (JSIndexer ss _ _) = ss

295290 go (JSObjectLiteral ss _) = ss

296− go (JSAccessor ss _ _) = ss

297291 go (JSFunction ss _ _ _) = ss

298292 go (JSApp ss _ _) = ss

299293 go (JSVar ss _) = ss

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

392383 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

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

4747optimize' js = do

4848 opts <- ask

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

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

5050 [ inlineCommonValues

5151 , inlineCommonOperators

5252 ]) js

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

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

1111

1212import Language.PureScript.Crash

1313import Language.PureScript.CodeGen.JS.AST

14−import Language.PureScript.PSString (mkString)

14+import Language.PureScript.PSString (PSString)

1515

1616applyAll :: [a -> a] -> a -> a

1717applyAll = foldl' (.) id

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

5555

5656targetVariable :: JS -> Text

5757targetVariable (JSVar _ var) = var

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

5958targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

6059targetVariable _ = internalError "Invalid argument to targetVariable"

6160

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

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

7170removeFromBlock _ js = js

7271

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

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

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

76−isFn (moduleName, fnName) (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

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

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

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

8275isDict _ _ = False

8376

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

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

8578isDict' 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

66 , inlineCommonValues

77 , inlineCommonOperators

88 , inlineFnComposition

9+ , inlineUnsafePartial

910 , etaConvert

1011 , unThunk

1112 , evaluateIifes

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

1718

1819import Data.Maybe (fromMaybe)

1920import Data.Monoid ((<>))

21+import Data.String (IsString, fromString)

2022import Data.Text (Text)

2123import qualified Data.Text as T

2224

25+import Language.PureScript.PSString (PSString)

2326import Language.PureScript.CodeGen.JS.AST

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

2528import qualified Language.PureScript.Constants as C

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

3336shouldInline (JSNumericLiteral _ _) = True

3437shouldInline (JSStringLiteral _ _) = True

3538shouldInline (JSBooleanLiteral _ _) = True

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

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

3840shouldInline _ = False

3941

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

6567 where

6668 convert :: JS -> JS

6769 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

6872 convert js = js

6973

7074inlineVariables :: JS -> JS

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

8286 where

8387 convert :: JS -> JS

8488 convert (JSApp ss fn [dict])

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

94100 convert other = other

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

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

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

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

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

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

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

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

104111

105112inlineCommonOperators :: JS -> JS

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

109116

110117 , binary ringNumber opSub Subtract

111118 , unary ringNumber opNegate Negate

112− , binary ringInt opSub Subtract

113− , unary ringInt opNegate Negate

114119

115120 , binary euclideanRingNumber opDiv Divide

116121 , binary euclideanRingInt opMod Modulus

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

167172 ] ++

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

169174 where

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

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

171176 binary dict fns op = everywhereOnJS convert

172177 where

173178 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

175180 convert other = other

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

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

177182 binary' moduleName opString op = everywhereOnJS convert

178183 where

179184 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

181186 convert other = other

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

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

183188 unary dicts fns op = everywhereOnJS convert

184189 where

185190 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

187192 convert other = other

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

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

189194 unary' moduleName fnName op = everywhereOnJS convert

190195 where

191196 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

193198 convert other = other

194199 mkFn :: Int -> JS -> JS

195200 mkFn 0 = everywhereOnJS convert

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

213218

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

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

217223 isNFn _ _ _ = False

218224

219225 runFn :: Int -> JS -> JS

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

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

235241 convert other = other

236242

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

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

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

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

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

239246 isModFn _ _ = False

240247

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

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

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

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

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

243251 isModFnWithDict _ _ = False

244252

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

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

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

248−inlineFnComposition = everywhereOnJSTopDownM convert

249− where

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

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

256+inlineFnComposition = everywhereOnJSTopDownM convert where

257+ convert :: JS -> m JS

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

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

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

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

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

261268 convert other = return other

262269 isFnCompose :: JS -> JS -> Bool

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

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

264271 isFnComposeFlipped :: JS -> JS -> Bool

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

266− fnCompose :: (Text, Text)

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

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

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

268− fnComposeFlipped :: (Text, Text)

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

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

270277

271−semiringNumber :: (Text, Text)

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+

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

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

273289

274−semiringInt :: (Text, Text)

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

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

276292

277−ringNumber :: (Text, Text)

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

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

279295

280−ringInt :: (Text, Text)

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

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

282298

283−euclideanRingNumber :: (Text, Text)

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

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

285301

286−euclideanRingInt :: (Text, Text)

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

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

288304

289−eqNumber :: (Text, Text)

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

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

291307

292−eqInt :: (Text, Text)

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

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

294310

295−eqString :: (Text, Text)

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

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

297313

298−eqChar :: (Text, Text)

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

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

300316

301−eqBoolean :: (Text, Text)

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

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

303319

304−ordBoolean :: (Text, Text)

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

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

306322

307−ordNumber :: (Text, Text)

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

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

309325

310−ordInt :: (Text, Text)

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

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

312328

313−ordString :: (Text, Text)

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

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

315331

316−ordChar :: (Text, Text)

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

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

318334

319−semigroupString :: (Text, Text)

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

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

321337

322−boundedBoolean :: (Text, Text)

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

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

324340

325−heytingAlgebraBoolean :: (Text, Text)

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

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

327343

328−semigroupoidFn :: (Text, Text)

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

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

330346

331−opAdd :: (Text, Text)

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

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

333349

334−opMul :: (Text, Text)

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

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

336352

337−opEq :: (Text, Text)

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

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

339355

340−opNotEq :: (Text, Text)

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

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

342358

343−opLessThan :: (Text, Text)

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

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

345361

346−opLessThanOrEq :: (Text, Text)

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

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

348364

349−opGreaterThan :: (Text, Text)

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

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

351367

352−opGreaterThanOrEq :: (Text, Text)

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

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

354370

355−opAppend :: (Text, Text)

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

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

357373

358−opSub :: (Text, Text)

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

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

360376

361−opNegate :: (Text, Text)

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

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

363379

364−opDiv :: (Text, Text)

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

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

366382

367−opMod :: (Text, Text)

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

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

369385

370−opConj :: (Text, Text)

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

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

372388

373−opDisj :: (Text, Text)

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

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

375391

376−opNot :: (Text, Text)

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

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

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

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

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

6565 isPure _ = False

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

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

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

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

7070 -- 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'

7272 isEffFunc _ _ = False

7373

7474 -- Remove __do function applications which remain after desugaring

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

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

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

109109 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

111111 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

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

115115 convert _ other = other

116116 -- 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'

118118 isSTFunc _ _ = False

119119 -- Find all ST Refs initialized in this block

120120 findSTRefsIn = everythingOnJS (++) isSTRef

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

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

8080 countSelfCallsUnderFunctions _ = 0

8181

8282 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

8494

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

8696 toLoop ident allArgs js = JSBlock rootSS $

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

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

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

110120 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 @@

22module Language.PureScript.Constants where

44import Prelude.Compat

5−import Data.Text (Text)

5+import Data.String (IsString)

66import Language.PureScript.Names

88-- Operators

10−($) :: Text

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

1111($) = "$"

1212

13−apply :: Text

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

1414apply = "apply"

1515

16−(#) :: Text

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

1717(#) = "#"

1818

19−applyFlipped :: Text

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

2020applyFlipped = "applyFlipped"

2121

22−(<>) :: Text

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

2323(<>) = "<>"

2424

25−(++) :: Text

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

2626(++) = "++"

2727

28−append :: Text

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

2929append = "append"

3030

31−(>>=) :: Text

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

3232(>>=) = ">>="

3333

34−bind :: Text

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

3535bind = "bind"

3636

37−(+) :: Text

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

3838(+) = "+"

3939

40−add :: Text

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

4141add = "add"

4242

43−(-) :: Text

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

4444(-) = "-"

4545

46−sub :: Text

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

4747sub = "sub"

4848

49−(*) :: Text

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

5050(*) = "*"

5151

52−mul :: Text

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

5353mul = "mul"

5454

55−(/) :: Text

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

5656(/) = "/"

5757

58−div :: Text

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

5959div = "div"

6060

61−(%) :: Text

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

6262(%) = "%"

6363

64−mod :: Text

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

6565mod = "mod"

6666

67−(<) :: Text

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

6868(<) = "<"

6969

70−lessThan :: Text

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

7171lessThan = "lessThan"

7272

73−(>) :: Text

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

7474(>) = ">"

7575

76−greaterThan :: Text

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

7777greaterThan = "greaterThan"

7878

79−(<=) :: Text

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

8080(<=) = "<="

8181

82−lessThanOrEq :: Text

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

8383lessThanOrEq = "lessThanOrEq"

8484

85−(>=) :: Text

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

8686(>=) = ">="

8787

88−greaterThanOrEq :: Text

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

8989greaterThanOrEq = "greaterThanOrEq"

9090

91−(==) :: Text

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

9292(==) = "=="

9393

94−eq :: Text

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

9595eq = "eq"

9696

97−(/=) :: Text

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

9898(/=) = "/="

9999

100−notEq :: Text

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

101101notEq = "notEq"

102102

103−compare :: Text

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

104104compare = "compare"

105105

106−(&&) :: Text

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

107107(&&) = "&&"

108108

109−conj :: Text

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

110110conj = "conj"

111111

112−(||) :: Text

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

113113(||) = "||"

114114

115−disj :: Text

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

116116disj = "disj"

117117

118−unsafeIndex :: Text

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

119119unsafeIndex = "unsafeIndex"

120120

121−or :: Text

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

122122or = "or"

123123

124−and :: Text

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

125125and = "and"

126126

127−xor :: Text

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

128128xor = "xor"

129129

130−(<<<) :: Text

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

131131(<<<) = "<<<"

132132

133−compose :: Text

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

134134compose = "compose"

135135

136−(>>>) :: Text

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

137137(>>>) = ">>>"

138138

139−composeFlipped :: Text

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

140140composeFlipped = "composeFlipped"

141141

142−map :: Text

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

143143map = "map"

144144

145145-- Functions

146146

147−negate :: Text

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

148148negate = "negate"

149149

150−not :: Text

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

151151not = "not"

152152

153−shl :: Text

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

154154shl = "shl"

155155

156−shr :: Text

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

157157shr = "shr"

158158

159−zshr :: Text

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

160160zshr = "zshr"

161161

162−complement :: Text

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

163163complement = "complement"

164164

165165-- Prelude Values

166166

167−zero :: Text

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

168168zero = "zero"

169169

170−one :: Text

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

171171one = "one"

172172

173−bottom :: Text

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

174174bottom = "bottom"

175175

176−top :: Text

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

177177top = "top"

178178

179−return :: Text

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

180180return = "return"

181181

182−pure' :: Text

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

183183pure' = "pure"

184184

185−returnEscaped :: Text

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

186186returnEscaped = "$return"

187187

188−untilE :: Text

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

189189untilE = "untilE"

190190

191−whileE :: Text

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

192192whileE = "whileE"

193193

194−runST :: Text

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

195195runST = "runST"

196196

197−stRefValue :: Text

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

198198stRefValue = "value"

199199

200−newSTRef :: Text

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

201201newSTRef = "newSTRef"

202202

203−readSTRef :: Text

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

204204readSTRef = "readSTRef"

205205

206−writeSTRef :: Text

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

207207writeSTRef = "writeSTRef"

208208

209−modifySTRef :: Text

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

210210modifySTRef = "modifySTRef"

211211

212−mkFn :: Text

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

213213mkFn = "mkFn"

214214

215−runFn :: Text

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

216216runFn = "runFn"

217217

218−unit :: Text

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

219219unit = "unit"

220220

221221-- Prim values

222222

223−undefined :: Text

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

224224undefined = "undefined"

225225

226226-- Type Class Dictionary Names

227227

228−monadEffDictionary :: Text

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

229229monadEffDictionary = "monadEff"

230230

231−applicativeEffDictionary :: Text

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

232232applicativeEffDictionary = "applicativeEff"

233233

234−bindEffDictionary :: Text

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

235235bindEffDictionary = "bindEff"

236236

237−semiringNumber :: Text

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

238238semiringNumber = "semiringNumber"

239239

240−semiringInt :: Text

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

241241semiringInt = "semiringInt"

242242

243−ringNumber :: Text

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

244244ringNumber = "ringNumber"

245245

246−ringInt :: Text

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

247247ringInt = "ringInt"

248248

249−moduloSemiringNumber :: Text

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

250250moduloSemiringNumber = "moduloSemiringNumber"

251251

252−moduloSemiringInt :: Text

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

253253moduloSemiringInt = "moduloSemiringInt"

254254

255−euclideanRingNumber :: Text

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

256256euclideanRingNumber = "euclideanRingNumber"

257257

258−euclideanRingInt :: Text

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

259259euclideanRingInt = "euclideanRingInt"

260260

261−ordBoolean :: Text

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

262262ordBoolean = "ordBoolean"

263263

264−ordNumber :: Text

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

265265ordNumber = "ordNumber"

266266

267−ordInt :: Text

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

268268ordInt = "ordInt"

269269

270−ordString :: Text

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

271271ordString = "ordString"

272272

273−ordChar :: Text

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

274274ordChar = "ordChar"

275275

276−eqNumber :: Text

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

277277eqNumber = "eqNumber"

278278

279−eqInt :: Text

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

280280eqInt = "eqInt"

281281

282−eqString :: Text

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

283283eqString = "eqString"

284284

285−eqChar :: Text

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

286286eqChar = "eqChar"

287287

288−eqBoolean :: Text

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

289289eqBoolean = "eqBoolean"

290290

291−boundedBoolean :: Text

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

292292boundedBoolean = "boundedBoolean"

293293

294−booleanAlgebraBoolean :: Text

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

295295booleanAlgebraBoolean = "booleanAlgebraBoolean"

296296

297−heytingAlgebraBoolean :: Text

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

298298heytingAlgebraBoolean = "heytingAlgebraBoolean"

299299

300−semigroupString :: Text

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

301301semigroupString = "semigroupString"

302302

303−semigroupoidFn :: Text

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

304304semigroupoidFn = "semigroupoidFn"

305305

306306-- Generic Deriving

307307

308−generic :: Text

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

309309generic = "Generic"

310310

311−toSpine :: Text

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

312312toSpine = "toSpine"

313313

314−fromSpine :: Text

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

315315fromSpine = "fromSpine"

316316

317−toSignature :: Text

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

318318toSignature = "toSignature"

319319

320320-- Data.Symbol

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

352352

353353-- Main module

354354

355−main :: Text

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

356356main = "main"

357357

358358-- Prim

359359

360−partial :: Text

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

361361partial = "Partial"

362362

363363pattern Prim :: ModuleName

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

369369pattern Fail :: Qualified (ProperName 'ClassName)

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

371371

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

373376typ = "Type"

374377

375−effect :: Text

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

376379effect = "Effect"

377380

378−symbol :: Text

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

379382symbol = "Symbol"

380383

381384-- Code Generation

382385

383−__superclass_ :: Text

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

384387__superclass_ = "__superclass_"

385388

386−__unused :: Text

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

387390__unused = "__unused"

388391

389392-- Modules

390393

391−prim :: Text

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

392395prim = "Prim"

393396

394−prelude :: Text

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

395398prelude = "Prelude"

396399

397−dataArray :: Text

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

398401dataArray = "Data_Array"

399402

400−eff :: Text

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

401404eff = "Control_Monad_Eff"

402405

403−st :: Text

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

404407st = "Control_Monad_ST"

405408

406−controlApplicative :: Text

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

407410controlApplicative = "Control_Applicative"

408411

409−controlSemigroupoid :: Text

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

410413controlSemigroupoid = "Control_Semigroupoid"

411414

412−controlBind :: Text

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

413416controlBind = "Control_Bind"

414417

415−dataBounded :: Text

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

416419dataBounded = "Data_Bounded"

417420

418−dataSemigroup :: Text

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

419422dataSemigroup = "Data_Semigroup"

420423

421−dataHeytingAlgebra :: Text

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

422425dataHeytingAlgebra = "Data_HeytingAlgebra"

423426

424−dataEq :: Text

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

425428dataEq = "Data_Eq"

426429

427−dataOrd :: Text

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

428431dataOrd = "Data_Ord"

429432

430−dataSemiring :: Text

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

431434dataSemiring = "Data_Semiring"

432435

433−dataRing :: Text

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

434437dataRing = "Data_Ring"

435438

436−dataEuclideanRing :: Text

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

437440dataEuclideanRing = "Data_EuclideanRing"

438441

439−dataFunction :: Text

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

440443dataFunction = "Data_Function"

441444

442−dataFunctionUncurried :: Text

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

443446dataFunctionUncurried = "Data_Function_Uncurried"

444447

445−dataIntBits :: Text

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

446449dataIntBits = "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 (

99import Language.PureScript.Docs.Convert as Docs

1010import Language.PureScript.Docs.Prim as Docs

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

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

1212import Language.PureScript.Docs.Render as Docs

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

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

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

1514import Language.PureScript.Docs.Types as Docs

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

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

7777codeToString :: RenderedCode -> Text

7878codeToString = outputWith elemAsMarkdown

7979 where

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

85− elemAsMarkdown Space = " "

80+ elemAsMarkdown (Syntax x) = x

81+ elemAsMarkdown (Keyword x) = x

82+ elemAsMarkdown Space = " "

83+ elemAsMarkdown (Symbol _ x _) = x

8684

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

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

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

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

44module Language.PureScript.Docs.Convert

55 ( convertModules

6+ , convertModulesWithEnv

67 , convertModulesInPackage

7− , collectBookmarks

8+ , convertModulesInPackageWithEnv

89 ) where

910

10−import Prelude.Compat

11+import Protolude hiding (check)

1112

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

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

1314import Control.Category ((>>>))

14−import Control.Monad

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

16−import Control.Monad.State (runStateT)

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

18−import Data.List (find)

1916import qualified Data.Map as Map

20−import Data.Text (Text)

17+import Data.String (String)

2118

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

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

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

2421import Language.PureScript.Docs.Types

2522import qualified Language.PureScript as P

2623import qualified Language.PureScript.Constants as C

2724

25+import Web.Bower.PackageMeta (PackageName)

26+

2827import Text.Parsec (eof)

2928

3029-- |

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

3433--

3534convertModulesInPackage ::

3635 (MonadError P.MultipleErrors m) =>

37− [InPackage P.Module] ->

36+ [P.Module] ->

37+ Map P.ModuleName PackageName ->

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

4048 go modules

4149 where

42− localNames =

43− map P.getModuleName (takeLocals modules)

4450 go =

45− map ignorePackage

46− >>> convertModules withPackage

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

51+ convertModulesWithEnv withPackage

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

4853

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

5055 withPackage mn =

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

52− Just m ->

53− fmap P.getModuleName m

54− Nothing ->

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

56− show (P.runModuleName mn)

56+ case Map.lookup mn modulesDeps of

57+ Just pkgName -> FromDep pkgName mn

58+ Nothing -> Local mn

59+

60+ isLocal :: P.ModuleName -> Bool

61+ isLocal = not . flip Map.member modulesDeps

5762

5863-- |

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

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

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

62−-- documenting re-exports.

65+-- producing documentation from.

6366--

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

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

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

7578 [P.Module] ->

7679 m [Module]

7780convertModules 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 =

7889 P.sortModules

7990 >>> fmap (fst >>> map importPrim)

8091 >=> convertSorted withPackage

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

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

8495

8596-- |

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.

8799--

88100convertSorted ::

89101 (MonadError P.MultipleErrors m) =>

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

91103 [P.Module] ->

92− m [Module]

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

93105convertSorted withPackage modules = do

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

95107

96108 modulesWithTypes <- typeCheckIfNecessary modules convertedModules

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

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

98110

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

101113

102114-- |

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

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

166178 other

167179

168180 parseIdent =

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

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

170182

171183 lookupName name =

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

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

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

11module Language.PureScript.Docs.Convert.Single

22 ( convertSingleModule

3− , collectBookmarks

43 ) where

65import Protolude

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

184183

185184 dropPrefix prefix str =

186185 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

5+import Protolude

7+import qualified Data.Map as M

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

2424 , boolean

2525 , partial

2626 , fail

27+ , warn

2728 , typeConcat

2829 , typeString

2930 , kindType

@@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines

225226 , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

226227 ]

227228

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+

228237typeConcat :: Declaration

229238typeConcat = primType "TypeConcat" $ T.unlines

230239 [ "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

2828renderDeclarationWithOptions opts Declaration{..} =

2929 mintersperse sp $ case declInfo of

3030 ValueDeclaration ty ->

31− [ ident declTitle

31+ [ ident' declTitle

3232 , syntax "::"

3333 , renderType' ty

3434 ]

@@ -70,40 +70,25 @@ renderDeclarationWithOptions opts Declaration{..} =

7070 [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]

7171 ]

7272 where

73− idents = mintersperse sp . map ident

73+ idents = mintersperse sp . map ident'

7474

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

75+ AliasDeclaration (P.Fixity associativity precedence) for ->

7676 [ keywordFixity associativity

7777 , syntax $ T.pack $ show precedence

78− , ident $ renderQualAlias for

79− , keyword "as"

80− , ident $ adjustAliasName alias declTitle

78+ , alias for

79+ , keywordAs

80+ , aliasName for declTitle

8181 ]

8282

8383 ExternKindDeclaration ->

8484 [ keywordKind

85− , renderKind (P.NamedKind (notQualified declTitle))

85+ , kind (notQualified declTitle)

8686 ]

8787

8888 where

8989 renderType' :: P.Type -> RenderedCode

9090 renderType' = renderTypeWithOptions opts

9191

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−

10792renderChildDeclaration :: ChildDeclaration -> RenderedCode

10893renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

10994

@@ -113,18 +98,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

11398 ChildInstance constraints ty ->

11499 maybeToList (renderConstraints constraints) ++ [ renderType' ty ]

115100 ChildDataConstructor args ->

116− [ renderType' typeApp' ]

117− where

118− typeApp' = foldl P.TypeApp ctor' args

119− ctor' = P.TypeConstructor (notQualified cdeclTitle)

101+ [ dataCtor' cdeclTitle ]

102+ ++ map renderTypeAtom' args

120103

121104 ChildTypeClassMember ty ->

122− [ ident cdeclTitle

105+ [ ident' cdeclTitle

123106 , syntax "::"

124107 , renderType' ty

125108 ]

126109 where

127110 renderType' = renderTypeWithOptions opts

111+ renderTypeAtom' = renderTypeAtomWithOptions opts

128112

129113renderConstraint :: P.Constraint -> RenderedCode

130114renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

@@ -151,6 +135,12 @@ renderConstraintsWithOptions opts constraints

151135notQualified :: Text -> P.Qualified (P.ProperName a)

152136notQualified = P.Qualified Nothing . P.ProperName

153137

138+ident' :: Text -> RenderedCode

139+ident' = ident . P.Qualified Nothing . P.Ident

140+

141+dataCtor' :: Text -> RenderedCode

142+dataCtor' = dataCtor . notQualified

143+

154144typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type

155145typeApp title typeArgs =

156146 foldl P.TypeApp

src/Language/PureScript/Docs/RenderedCode.hs+9−8

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

1−

2−-- | Data types and functions for representing a simplified form of PureScript

3−-- code, intended for use in e.g. HTML documentation.

4−

5−module Language.PureScript.Docs.RenderedCode (module RenderedCode) where

6−

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

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

2+-- | Data types and functions for representing a simplified form of PureScript

3+-- code, intended for use in e.g. HTML documentation.

5+module Language.PureScript.Docs.RenderedCode (module RenderedCode) where

7+import Language.PureScript.Docs.RenderedCode.Types 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

7+-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds.

8+-- Ideally we would unify the two.

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

11-- | Functions for producing RenderedCode values from PureScript Type values.

3−module Language.PureScript.Docs.RenderedCode.Render

3+module Language.PureScript.Docs.RenderedCode.RenderType

44 ( renderType

55 , renderTypeAtom

66 , renderRow

7− , renderKind

87 , RenderTypeOptions(..)

98 , defaultRenderTypeOptions

109 , renderTypeWithOptions

10+ , renderTypeAtomWithOptions

1111 ) where

1212

1313import Prelude.Compat

@@ -20,39 +20,40 @@ import Control.Arrow ((<+>))

2020import Control.PatternArrows as PA

2121

2222import Language.PureScript.Crash

23−import Language.PureScript.Docs.RenderedCode.Types

24−import Language.PureScript.Docs.Utils.MonoidExtras

2523import Language.PureScript.Environment

2624import Language.PureScript.Kinds

2725import Language.PureScript.Names

28−import Language.PureScript.Pretty.Kinds

2926import Language.PureScript.Pretty.Types

3027import Language.PureScript.Types

3128import Language.PureScript.Label (Label)

3229

30+import Language.PureScript.Docs.RenderedCode.Types

31+import Language.PureScript.Docs.Utils.MonoidExtras

32+import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)

33+

3334typeLiterals :: Pattern () Type RenderedCode

3435typeLiterals = mkPattern match

3536 where

3637 match TypeWildcard{} =

3738 Just (syntax "_")

3839 match (TypeVar var) =

39− Just (ident var)

40+ Just (typeVar var)

4041 match (PrettyPrintObject row) =

4142 Just $ mintersperse sp

4243 [ syntax "{"

4344 , renderRow row

4445 , syntax "}"

4546 ]

46− match (TypeConstructor (Qualified mn name)) =

47− Just (ctor (runProperName name) (maybeToContainingModule mn))

47+ match (TypeConstructor n) =

48+ Just (typeCtor n)

4849 match REmpty =

4950 Just (syntax "()")

5051 match row@RCons{} =

5152 Just (syntax "(" <> renderRow row <> syntax ")")

5253 match (BinaryNoParensType op l r) =

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

54− match (TypeOp (Qualified mn op)) =

55− Just (ident' (runOpName op) (maybeToContainingModule mn))

55+ match (TypeOp n) =

56+ Just (typeOp n)

5657 match _ =

5758 Nothing

5859

@@ -87,7 +88,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel

8788renderLabel :: (Label, Type) -> RenderedCode

8889renderLabel (label, ty) =

8990 mintersperse sp

90− [ syntax $ prettyPrintLabel label

91+ [ typeVar $ prettyPrintLabel label

9192 , syntax "::"

9293 , renderType ty

9394 ]

@@ -139,7 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

139140 OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]

140141 , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]

141142 , [ 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] ]

143144 , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]

144145 , [ Wrap explicitParens $ \_ ty -> ty ]

145146 ]

@@ -154,12 +155,6 @@ insertPlaceholders :: RenderTypeOptions -> Type -> Type

154155insertPlaceholders opts =

155156 everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)

156157

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−

163158convert :: RenderTypeOptions -> Type -> Type

164159convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

165160convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r

@@ -173,28 +168,20 @@ convertForAlls (ForAll i ty _) = go [i] ty

173168convertForAlls other = other

174169

175170preprocessType :: RenderTypeOptions -> Type -> Type

176−preprocessType opts = dePrim . insertPlaceholders opts

171+preprocessType opts = insertPlaceholders opts

172+

177173

178174-- |

179−-- Render code representing a Kind

175+-- Render code representing a Type

180176--

181−renderKind :: Kind -> RenderedCode

182−renderKind = kind . prettyPrintKind

177+renderType :: Type -> RenderedCode

178+renderType = renderTypeWithOptions defaultRenderTypeOptions

183179

184180-- |

185181-- Render code representing a Type, as it should appear inside parentheses

186182--

187183renderTypeAtom :: 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

198185

199186data RenderTypeOptions = RenderTypeOptions

200187 { prettyPrintObjects :: Bool

@@ -213,3 +200,9 @@ renderTypeWithOptions opts

213200 = fromMaybe (internalError "Incomplete pattern")

214201 . PA.pattern matchType ()

215202 . 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 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE DeriveGeneric #-}

34-- | Data types and functions for representing a simplified form of PureScript

45-- code, intended for use in e.g. HTML documentation.

@@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types

1112 , containingModuleToMaybe

1213 , maybeToContainingModule

1314 , fromContainingModule

15+ , fromQualified

16+ , Namespace(..)

17+ , Link(..)

18+ , FixityAlias

1419 , RenderedCode

1520 , asRenderedCode

1621 , outputWith

1722 , sp

23+ , parens

1824 , syntax

19− , ident

20− , ident'

21− , ctor

22− , kind

2325 , keyword

2426 , keywordForall

2527 , keywordData

@@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types

3032 , keywordWhere

3133 , keywordFixity

3234 , keywordKind

35+ , keywordAs

36+ , ident

37+ , dataCtor

38+ , typeCtor

39+ , typeOp

40+ , typeVar

41+ , kind

42+ , alias

43+ , aliasName

3344 ) where

3445

3546import Prelude.Compat

47+import GHC.Generics (Generic)

3648

49+import Control.DeepSeq (NFData)

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

3851

52+import Data.Monoid ((<>))

3953import Data.Aeson.BetterErrors

4054import qualified Data.Aeson as A

4155import 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

4259

43−import qualified Language.PureScript as P

60+import Language.PureScript.Names

61+import Language.PureScript.AST (Associativity(..))

62+import Language.PureScript.Crash (internalError)

4463

45−-- |

46−-- A single element in a rendered code fragment. The intention is to support

47−-- multiple output formats. For example, plain text, or highlighted HTML.

48−--

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)

64+-- | Given a list of actions, attempt them all, returning the first success.

65+-- If all the actions fail, 'tryAll' returns the first argument.

66+tryAll :: MonadError e m => m a -> [m a] -> m a

67+tryAll = foldr $ \x y -> catchError x (const y)

5768

58−instance A.ToJSON RenderedCodeElement where

59− toJSON (Syntax str) =

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

69+firstEq :: Text -> Parse Text a -> Parse Text a

70+firstEq str p = nth 0 (withText (eq str)) *> p

8171 where

82− p <|> q = catchError p (const q)

72+ eq s s' = if s == s' then Right () else Left ""

8373

84− a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)

85− asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)

86− asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)

87− asSpace = nth 0 (withText (eq "space")) *> pure Space

74+-- |

75+-- Try the given parsers in sequence. If all fail, fail with the given message,

76+-- and include the JSON in the error.

77+--

78+tryParse :: Text -> [Parse Text a] -> Parse Text a

79+tryParse msg =

80+ tryAll (withValue (Left . (fullMsg <>) . showJSON))

8881

89− eq s s' = if s == s' then Right () else Left ""

82+ where

83+ fullMsg = "Invalid " <> msg <> ": "

9084

91− unableToParse = withText Left

85+ showJSON :: A.Value -> Text

86+ showJSON = TE.decodeUtf8 . BS.toStrict . A.encode

9287

9388-- |

94−-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier

95−-- to read, as the meaning is more explicit.

89+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit

90+-- easier to read, as the meaning is more explicit.

9691--

9792data ContainingModule

9893 = ThisModule

99− | OtherModule P.ModuleName

94+ | OtherModule ModuleName

10095 deriving (Show, Eq, Ord)

10196

10297instance 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]

104103

105−asContainingModule :: Parse e ContainingModule

104+instance A.FromJSON ContainingModule where

105+ parseJSON = toAesonParser id asContainingModule

106+

107+asContainingModule :: Parse Text ContainingModule

106108asContainingModule =

107− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)

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 =

119+ [ maybeToContainingModule <$> perhaps asModuleName

120+ ]

121+

122+ asModuleName = moduleNameFromString <$> asText

108123

109124-- |

110−-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious

125+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious

111126-- isomorphism.

112127--

113−maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule

128+maybeToContainingModule :: Maybe ModuleName -> ContainingModule

114129maybeToContainingModule Nothing = ThisModule

115130maybeToContainingModule (Just mn) = OtherModule mn

116131

117132-- |

118−-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious

133+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious

119134-- isomorphism.

120135--

121−containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName

136+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName

122137containingModuleToMaybe ThisModule = Nothing

123138containingModuleToMaybe (OtherModule mn) = Just mn

124139

125140-- |

126141-- A version of 'fromMaybe' for 'ContainingModule' values.

127142--

128−fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName

143+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName

129144fromContainingModule def ThisModule = def

130145fromContainingModule _ (OtherModule mn) = mn

131146

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+

132245-- |

133246-- A type representing a highly simplified version of PureScript code, intended

134247-- for use in output formats like plain text or HTML.

@@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC

158271sp :: RenderedCode

159272sp = RC [Space]

160273

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.

161282syntax :: Text -> RenderedCode

162283syntax x = RC [Syntax x]

163284

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−

176285keyword :: Text -> RenderedCode

177286keyword kw = RC [Keyword kw]

178287

@@ -197,10 +306,78 @@ keywordInstance = keyword "instance"

197306keywordWhere :: RenderedCode

198307keywordWhere = keyword "where"

199308

200−keywordFixity :: P.Associativity -> RenderedCode

201−keywordFixity P.Infixl = keyword "infixl"

202−keywordFixity P.Infixr = keyword "infixr"

203−keywordFixity P.Infix = keyword "infix"

309+keywordFixity :: Associativity -> RenderedCode

310+keywordFixity Infixl = keyword "infixl"

311+keywordFixity Infixr = keyword "infixr"

312+keywordFixity Infix = keyword "infix"

204313

205314keywordKind :: RenderedCode

206315keywordKind = 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

44 )

55 where

7−import Prelude.Compat

7+import Protolude hiding (to, from)

8+import Prelude (String, unlines)

9−import Control.Arrow (first, (***))

10−import Control.Monad (when)

11−import Control.Monad.Error.Class (catchError)

10+import Control.Arrow ((***))

1211

1312import Data.Aeson ((.=))

1413import Data.Aeson.BetterErrors

15−import Data.ByteString.Lazy (ByteString)

16−import Data.Either (isLeft, isRight)

17−import Data.Maybe (mapMaybe, fromMaybe, maybeToList)

18−import Data.Monoid ((<>))

19−import Data.Text (Text)

14+import qualified Data.Map as Map

2015import Data.Time.Clock (UTCTime)

2116import qualified Data.Time.Format as TimeFormat

2217import Data.Version

@@ -33,7 +28,8 @@ import Web.Bower.PackageMeta hiding (Version, displayError)

3328import Language.PureScript.Docs.RenderedCode as ReExports

3429 (RenderedCode, asRenderedCode,

3530 ContainingModule(..), asContainingModule,

36− RenderedCodeElement(..), asRenderedCodeElement)

31+ RenderedCodeElement(..), asRenderedCodeElement,

32+ Namespace(..), FixityAlias)

3733

3834--------------------

3935-- Types

@@ -47,7 +43,7 @@ data Package a = Package

4743 -- field. It should eventually be changed to just UTCTime.

4844 , pkgTagTime :: Maybe UTCTime

4945 , pkgModules :: [Module]

50− , pkgBookmarks :: [Bookmark]

46+ , pkgModuleMap :: Map P.ModuleName PackageName

5147 , pkgResolvedDependencies :: [(PackageName, Version)]

5248 , pkgGithub :: (GithubUser, GithubRepo)

5349 , pkgUploader :: a

@@ -70,7 +66,7 @@ verifyPackage verifiedUser Package{..} =

7066 pkgVersionTag

7167 pkgTagTime

7268 pkgModules

73− pkgBookmarks

69+ pkgModuleMap

7470 pkgResolvedDependencies

7571 pkgGithub

7672 verifiedUser

@@ -188,8 +184,6 @@ convertFundepsToStrings args fundeps =

188184 ) $ argsVec V.!? i

189185 toArgs from to = (map getArg from, map getArg to)

190186

191−type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)))

192−

193187declInfoToString :: DeclarationInfo -> Text

194188declInfoToString (ValueDeclaration _) = "value"

195189declInfoToString (DataDeclaration _ _) = "data"

@@ -199,6 +193,23 @@ declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

199193declInfoToString (AliasDeclaration _ _) = "alias"

200194declInfoToString ExternKindDeclaration = "kind"

201195

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+

202213isTypeClass :: Declaration -> Bool

203214isTypeClass Declaration{..} =

204215 case declInfo of

@@ -274,6 +285,20 @@ childDeclInfoToString (ChildInstance _ _) = "instance"

274285childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

275286childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

276287

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+

277302isTypeClassMember :: ChildDeclaration -> Bool

278303isTypeClassMember ChildDeclaration{..} =

279304 case cdeclInfo of

@@ -308,8 +333,6 @@ data PackageError

308333 | InvalidTime

309334 deriving (Show, Eq, Ord)

310335

311−type Bookmark = InPackage (P.ModuleName, Text)

312−

313336data InPackage a

314337 = Local a

315338 | FromDep PackageName a

@@ -333,10 +356,10 @@ ignorePackage (FromDep _ x) = x

333356----------------------

334357-- Parsing

335358

336−parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage

359+parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage

337360parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion

338361

339−parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage

362+parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage

340363parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion

341364

342365asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)

@@ -353,11 +376,15 @@ asPackage minimumVersion uploader = do

353376 <*> key "versionTag" asText

354377 <*> keyMay "tagTime" (withString parseTimeEither)

355378 <*> key "modules" (eachInArray asModule)

356− <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

379+ <*> moduleMap

357380 <*> key "resolvedDependencies" asResolvedDependencies

358381 <*> key "github" asGithub

359382 <*> key "uploader" uploader

360383 <*> pure compilerVersion

384+ where

385+ moduleMap =

386+ key "moduleMap" asModuleMap

387+ `pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta)

361388

362389parseTimeEither :: String -> Either PackageError UTCTime

363390parseTimeEither =

@@ -444,9 +471,10 @@ asReExport =

444471 asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)

445472 asReExportModuleName =

446473 asInPackage fromAesonParser .! ErrorInPackageMeta

447− <|> fmap Local fromAesonParser

474+ `pOr` fmap Local fromAesonParser

448475

449− (<|>) p q = catchError p (const q)

476+pOr :: Parse e a -> Parse e a -> Parse e a

477+p `pOr` q = catchError p (const q)

450478

451479asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)

452480asInPackage inner =

@@ -559,20 +587,38 @@ asQualifiedProperName = fromAesonParser

559587asQualifiedIdent :: Parse e (P.Qualified P.Ident)

560588asQualifiedIdent = fromAesonParser

561589

562−asBookmarks :: Parse BowerError [Bookmark]

563−asBookmarks = eachInArray asBookmark

590+asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)

591+asModuleMap =

592+ Map.fromList <$>

593+ eachInObjectWithKey (Right . P.moduleNameFromString)

594+ (withText parsePackageName')

564595

565−asBookmark :: Parse BowerError Bookmark

566−asBookmark =

567− asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)

568− <*> nth 1 asText)

596+-- This is here to preserve backwards compatibility with compilers which used

597+-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should

598+-- remove this after the next breaking change to the JSON.

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)

569610

570611asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

571612asResolvedDependencies =

572− eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion

573− where

574− mapLeft f (Left x) = Left (f x)

575− mapLeft _ (Right x) = Right x

613+ eachInObjectWithKey parsePackageName' asVersion

614+

615+parsePackageName' :: Text -> Either PackageError PackageName

616+parsePackageName' =

617+ mapLeft ErrorInPackageMeta . parsePackageName

618+

619+mapLeft :: (a -> a') -> Either a b -> Either a' b

620+mapLeft f (Left x) = Left (f x)

621+mapLeft _ (Right x) = Right x

576622

577623asGithub :: Parse e (GithubUser, GithubRepo)

578624asGithub = (,) <$> nth 0 (GithubUser <$> asText)

@@ -593,7 +639,9 @@ instance A.ToJSON a => A.ToJSON (Package a) where

593639 , "version" .= showVersion pkgVersion

594640 , "versionTag" .= pkgVersionTag

595641 , "modules" .= pkgModules

596− , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks

642+ , "moduleMap" .= assocListToJSON P.runModuleName

643+ runPackageName

644+ (Map.toList pkgModuleMap)

597645 , "resolvedDependencies" .= assocListToJSON runPackageName

598646 (T.pack . showVersion)

599647 pkgResolvedDependencies

src/Language/PureScript/Environment.hs+6−3

@@ -347,7 +347,7 @@ primKinds =

347347

348348-- |

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

351351-- that correspond to the classes with the same names.

352352--

353353primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

@@ -363,20 +363,23 @@ primTypes =

363363 , (primName "Boolean", (kindType, ExternData))

364364 , (primName "Partial", (kindType, ExternData))

365365 , (primName "Fail", (FunKind kindSymbol kindType, ExternData))

366+ , (primName "Warn", (FunKind kindSymbol kindType, ExternData))

366367 , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

367368 , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

368369 ]

369370

370371-- |

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`

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

374376--

375377primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

376378primClasses =

377379 M.fromList

378380 [ (primName "Partial", (makeTypeClassData [] [] [] []))

379381 , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

382+ , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

380383 ]

381384

382385-- |

src/Language/PureScript/Errors.hs+79−87

@@ -6,44 +6,40 @@ module Language.PureScript.Errors

66 , module Language.PureScript.Errors

77 ) where

9−import Prelude.Compat

10−

11−import Control.Arrow ((&&&))

12−import Control.Monad

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

14−import Control.Monad.Trans.State.Lazy

15−import Control.Monad.Writer

16−

17−import Data.Char (isSpace)

18−import Data.Either (lefts, rights)

19−import Data.Foldable (fold)

20−import Data.Functor.Identity (Identity(..))

21−import Data.List (transpose, nub, nubBy, sortBy, partition)

22−import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

23−import Data.Ord (comparing)

9+import Prelude.Compat

10+

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

12+import Control.Monad

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

14+import Control.Monad.Trans.State.Lazy

15+import Control.Monad.Writer

16+import Data.Char (isSpace)

17+import Data.Either (lefts, rights)

18+import Data.Foldable (fold)

19+import Data.Functor.Identity (Identity(..))

20+import Data.List (transpose, nub, nubBy, sortBy, partition)

21+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

22+import Data.Ord (comparing)

2423import qualified Data.Map as M

2524import qualified Data.Text as T

26−import Data.Text (Text)

27−

28−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)

25+import Data.Text (Text)

26+import Language.PureScript.AST

3727import qualified Language.PureScript.Bundle as Bundle

3828import 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

4038import qualified System.Console.ANSI as ANSI

41−

4239import qualified Text.Parsec as P

4340import qualified Text.Parsec.Error as PE

41+import Text.Parsec.Error (Message(..))

4442import qualified Text.PrettyPrint.Boxes as Box

45−import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

46−import Text.Parsec.Error (Message(..))

4743

4844newtype ErrorSuggestion = ErrorSuggestion Text

4945

@@ -72,11 +68,10 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt

7268 shouldStrip (PositionedError _) = True

7369 shouldStrip _ = False

7470

75−-- |

76−-- Get the error code for a particular error type

77−--

71+-- | Get the error code for a particular error type

7872errorCode :: ErrorMessage -> Text

7973errorCode em = case unwrapErrorMessage em of

74+ ModuleNotFound{} -> "ModuleNotFound"

8075 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

8176 ErrorParsingModule{} -> "ErrorParsingModule"

8277 MissingFFIModule{} -> "MissingFFIModule"

@@ -168,31 +163,27 @@ errorCode em = case unwrapErrorMessage em of

168163 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

169164 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

170165 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

171− DeprecatedRequirePath{} -> "DeprecatedRequirePath"

172166 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

173167 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

174168 ExpectedWildcard{} -> "ExpectedWildcard"

175169 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

170+ ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"

171+ UserDefinedWarning{} -> "UserDefinedWarning"

176172

177−-- |

178−-- A stack trace for an error

179−--

173+-- | A stack trace for an error

180174newtype MultipleErrors = MultipleErrors

181− { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

175+ { runMultipleErrors :: [ErrorMessage]

176+ } deriving (Show, Monoid)

182177

183178-- | Check whether a collection of errors is empty or not.

184179nonEmpty :: MultipleErrors -> Bool

185180nonEmpty = not . null . runMultipleErrors

186181

187−-- |

188−-- Create an error set from a single simple error message

189−--

182+-- | Create an error set from a single simple error message

190183errorMessage :: SimpleErrorMessage -> MultipleErrors

191184errorMessage err = MultipleErrors [ErrorMessage [] err]

192185

193−-- |

194−-- Create an error set from a single error message

195−--

186+-- | Create an error set from a single error message

196187singleError :: ErrorMessage -> MultipleErrors

197188singleError = MultipleErrors . pure

198189

@@ -225,15 +216,12 @@ defaultUnknownMap = TypeMap M.empty M.empty 0

225216-- | How critical the issue is

226217data Level = Error | Warning deriving Show

227218

228−-- |

229−-- Extract nested error messages from wrapper errors

230−--

219+-- | Extract nested error messages from wrapper errors

231220unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

232221unwrapErrorMessage (ErrorMessage _ se) = se

233222

234223replaceUnknowns :: Type -> State TypeMap Type

235−replaceUnknowns = everywhereOnTypesM replaceTypes

236− where

224+replaceUnknowns = everywhereOnTypesM replaceTypes where

237225 replaceTypes :: Type -> State TypeMap Type

238226 replaceTypes (TUnknown u) = do

239227 m <- get

@@ -386,10 +374,7 @@ defaultPPEOptions = PPEOptions

386374 , ppeShowDocs = True

387375 }

388376

389−

390−-- |

391−-- Pretty print a single error, simplifying if necessary

392−--

377+-- | Pretty print a single error, simplifying if necessary

393378prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box

394379prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do

395380 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

@@ -430,6 +415,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

430415 unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"

431416

432417 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+ ]

433422 renderSimpleErrorMessage (CannotGetFileInfo path) =

434423 paras [ line "Unable to read file info: "

435424 , indent . lineS $ path

@@ -691,7 +680,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

691680 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

692681 line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)

693682 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) <> "."

695684 , line "The error arises from the type"

696685 , markCodeBox $ indent $ typeAsBox ty

697686 , line "having the kind"

@@ -863,9 +852,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

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

864853 ]

865854

866− renderSimpleErrorMessage DeprecatedRequirePath =

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

868−

869855 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

870856 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

871857 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

@@ -885,6 +871,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

885871 paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

886872 ]

887873

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+

888887 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

889888 renderHint (ErrorUnifyingTypes t1 t2) detail =

890889 paras [ detail

@@ -1165,15 +1164,11 @@ prettyPrintRef (ReExportRef _ _) =

11651164prettyPrintRef (PositionedDeclarationRef _ _ ref) =

11661165 prettyPrintRef ref

11671166

1168−-- |

1169−-- Pretty print multiple errors

1170−--

1167+-- | Pretty print multiple errors

11711168prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String

11721169prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions

11731170

1174−-- |

1175−-- Pretty print multiple warnings

1176−--

1171+-- | Pretty print multiple warnings

11771172prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String

11781173prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions

11791174

@@ -1204,11 +1199,10 @@ prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =

12041199prettyPrintParseError :: P.ParseError -> Box.Box

12051200prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages

12061201

1207−-- |

1208−-- 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>.

1202+-- | Pretty print 'ParseError' detail messages.

12111203--

1204+-- Adapted from 'Text.Parsec.Error.showErrorMessages'.

1205+-- See <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.

12121206prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box

12131207prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs

12141208 | null msgs = Box.text msgUnknown

@@ -1277,9 +1271,7 @@ toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

12771271 | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)

12781272toTypelevelString _ = Nothing

12791273

1280−-- |

1281−-- Rethrow an error with a more detailed error message in the case of failure

1282−--

1274+-- | Rethrow an error with a more detailed error message in the case of failure

12831275rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

12841276rethrow f = flip catchError $ \e -> throwError (f e)

12851277

@@ -1292,9 +1284,7 @@ reflectErrors ma = ma >>= either throwError return

12921284warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a

12931285warnAndRethrow f = rethrow f . censor f

12941286

1295−-- |

1296−-- Rethrow an error with source position information

1297−--

1287+-- | Rethrow an error with source position information

12981288rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

12991289rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))

13001290

@@ -1307,10 +1297,8 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

13071297withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

13081298withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se

13091299

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

13121301-- that match the predicate to error status.

1313−--

13141302escalateWarningWhen

13151303 :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)

13161304 => (ErrorMessage -> Bool)

@@ -1323,16 +1311,20 @@ escalateWarningWhen isError ma = do

13231311 unless (null errors) $ throwError $ MultipleErrors errors

13241312 return a

13251313

1326−-- |

1327−-- Collect errors in in parallel

1328−--

1329−parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]

1330−parU xs f = forM xs (withError . f) >>= collectErrors

1314+-- | Collect errors in in parallel

1315+parU

1316+ :: forall m a b

1317+ . MonadError MultipleErrors m

1318+ => [a]

1319+ -> (a -> m b)

1320+ -> m [b]

1321+parU xs f =

1322+ forM xs (withError . f) >>= collectErrors

13311323 where

1332− withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)

1333− withError u = catchError (Right <$> u) (return . Left)

1324+ withError :: m b -> m (Either MultipleErrors b)

1325+ withError u = catchError (Right <$> u) (return . Left)

13341326

1335− collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]

1336− collectErrors es = case lefts es of

1337− [] -> return $ rights es

1338− errs -> throwError $ fold errs

1327+ collectErrors :: [Either MultipleErrors b] -> m [b]

1328+ collectErrors es = case lefts es of

1329+ [] -> return $ rights es

1330+ errs -> throwError $ fold errs

src/Language/PureScript/Make.hs+80−87

@@ -20,53 +20,51 @@ module Language.PureScript.Make

2020 , inferForeignModules

2121 ) where

2222

23−import Prelude.Compat

24−

25−import Control.Concurrent.Lifted as C

26−import Control.Monad hiding (sequence)

27−import Control.Monad.Base (MonadBase(..))

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

29−import Control.Monad.IO.Class

30−import Control.Monad.Logger

31−import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

32−import Control.Monad.Supply

33−import Control.Monad.Trans.Class (MonadTrans(..))

34−import Control.Monad.Trans.Control (MonadBaseControl(..))

35−import Control.Monad.Trans.Except

36−import Control.Monad.Writer.Class (MonadWriter(..))

37−

38−import Data.Aeson (encode, decode)

23+import Prelude.Compat

24+

25+import Control.Concurrent.Lifted as C

26+import Control.Monad hiding (sequence)

27+import Control.Monad.Base (MonadBase(..))

28+import Control.Monad.Error.Class (MonadError(..))

29+import Control.Monad.IO.Class

30+import Control.Monad.Logger

31+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

32+import Control.Monad.Supply

33+import Control.Monad.Trans.Class (MonadTrans(..))

34+import Control.Monad.Trans.Control (MonadBaseControl(..))

35+import Control.Monad.Trans.Except

36+import Control.Monad.Writer.Class (MonadWriter(..))

37+import Data.Aeson (encode, decode)

3938import qualified Data.Aeson as Aeson

40−import Data.Either (partitionEithers)

41−import Data.Function (on)

42−import Data.Foldable (for_)

43−import Data.List (foldl', sortBy, groupBy)

44−import Data.Maybe (fromMaybe, catMaybes)

45−import Data.Monoid ((<>))

46−import Data.Time.Clock

47−import Data.Traversable (for)

48−import Data.Version (showVersion)

39+import Data.Either (partitionEithers)

40+import Data.Function (on)

41+import Data.Foldable (for_)

42+import Data.List (foldl', sortBy, groupBy)

43+import Data.Maybe (fromMaybe, catMaybes)

44+import Data.Monoid ((<>))

45+import Data.Time.Clock

46+import Data.Traversable (for)

47+import Data.Version (showVersion)

4948import qualified Data.ByteString.Lazy as B

5049import qualified Data.ByteString.UTF8 as BU8

5150import qualified Data.Map as M

5251import qualified Data.Set as S

5352import qualified Data.Text as T

5453import qualified Data.Text.Encoding as TE

55−

56−import Language.PureScript.AST

57−import Language.PureScript.Crash

58−import Language.PureScript.Environment

59−import Language.PureScript.Errors

60−import Language.PureScript.Externs

61−import Language.PureScript.Linter

62−import Language.PureScript.ModuleDependencies

63−import Language.PureScript.Names

64−import Language.PureScript.Options

65−import Language.PureScript.Pretty

66−import Language.PureScript.Pretty.Common(SMap(..))

67−import Language.PureScript.Renamer

68−import Language.PureScript.Sugar

69−import Language.PureScript.TypeChecker

54+import Language.PureScript.AST

55+import Language.PureScript.Crash

56+import Language.PureScript.Environment

57+import Language.PureScript.Errors

58+import Language.PureScript.Externs

59+import Language.PureScript.Linter

60+import Language.PureScript.ModuleDependencies

61+import Language.PureScript.Names

62+import Language.PureScript.Options

63+import Language.PureScript.Pretty

64+import Language.PureScript.Pretty.Common(SMap(..))

65+import Language.PureScript.Renamer

66+import Language.PureScript.Sugar

67+import Language.PureScript.TypeChecker

7068import qualified Language.JavaScript.Parser as JS

7169import qualified Language.PureScript.Bundle as Bundle

7270import qualified Language.PureScript.CodeGen.JS as J

@@ -74,21 +72,18 @@ import qualified Language.PureScript.Constants as C

7472import qualified Language.PureScript.CoreFn as CF

7573import qualified Language.PureScript.CoreFn.ToJSON as CFJ

7674import qualified Language.PureScript.Parser as PSParser

77−

7875import qualified Paths_purescript as Paths

79−

80−import SourceMap

81−import SourceMap.Types

82−

83−import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

84−import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

85−import System.IO.Error (tryIOError)

86−

76+import SourceMap

77+import SourceMap.Types

78+import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

79+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

80+import System.IO.Error (tryIOError)

8781import qualified Text.Parsec as Parsec

8882

8983-- | Progress messages from the make process

9084data ProgressMessage

9185 = CompilingModule ModuleName

86+ -- ^ Compilation started for the specified module

9287 deriving (Show, Eq, Ord)

9388

9489-- | Render a progress message

@@ -102,7 +97,6 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule

10297-- * The particular backend being used (Javascript, C++11, etc.)

10398--

10499-- * The details of how files are read/written etc.

105−--

106100data MakeActions m = MakeActions

107101 { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))

108102 -- ^ Get the timestamp for the input file(s) for a module. If there are multiple

@@ -121,26 +115,26 @@ data MakeActions m = MakeActions

121115 -- ^ Respond to a progress update.

122116 }

123117

124−-- |

125−-- Generated code for an externs file.

126−--

118+-- | Generated code for an externs file.

127119type Externs = B.ByteString

128120

129−-- |

130−-- Determines when to rebuild a module

131−--

121+-- | Determines when to rebuild a module

132122data RebuildPolicy

133123 -- | Never rebuild this module

134124 = RebuildNever

135125 -- | Always rebuild this module

136126 | RebuildAlways deriving (Show, Eq, Ord)

137127

138−-- | Rebuild a single module

139−rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

140− => MakeActions m

141− -> [ExternsFile]

142− -> Module

143− -> m ExternsFile

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

133+ . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

134+ => MakeActions m

135+ -> [ExternsFile]

136+ -> Module

137+ -> m ExternsFile

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

145139 progress $ CompilingModule moduleName

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

@@ -157,12 +151,10 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

157151 evalSupplyT nextVar . codegen renamed env' . encode $ exts

158152 return exts

159153

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.

162155--

163156-- If timestamps have not changed, the externs file can be used to provide the module's types without

164157-- having to typecheck the module again.

165−--

166158make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

167159 => MakeActions m

168160 -> [Module]

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

244236 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs

245237 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors

246238

247− maximumMaybe :: (Ord a) => [a] -> Maybe a

239+ maximumMaybe :: Ord a => [a] -> Maybe a

248240 maximumMaybe [] = Nothing

249241 maximumMaybe xs = Just $ maximum xs

250242

@@ -262,11 +254,10 @@ make ma@MakeActions{..} ms = do

262254importPrim :: Module -> Module

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

264256

265−-- |

266−-- A monad for running make actions

267−--

268−newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }

269− deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

257+-- | A monad for running make actions

258+newtype Make a = Make

259+ { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a

260+ } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)

270261

271262instance MonadBase IO Make where

272263 liftBase = liftIO

@@ -276,12 +267,12 @@ instance MonadBaseControl IO Make where

276267 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)

277268 restoreM = Make . restoreM

278269

279−-- |

280−-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

281−--

270+-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.

282271runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)

283272runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake

284273

274+-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should

275+-- be rendered as 'ErrorMessage' values.

285276makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a

286277makeIO f io = do

287278 e <- liftIO $ tryIOError io

@@ -299,7 +290,8 @@ inferForeignModules

299290 . MonadIO m

300291 => M.Map ModuleName (Either RebuildPolicy FilePath)

301292 -> m (M.Map ModuleName FilePath)

302−inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule

293+inferForeignModules =

294+ fmap (M.mapMaybe id) . traverse inferForeignModule

303295 where

304296 inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)

305297 inferForeignModule (Left _) = return Nothing

@@ -310,16 +302,19 @@ inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule

310302 then return (Just jsFile)

311303 else return Nothing

312304

313−-- |

314−-- A set of make actions that read and write modules from the given directory.

315−--

316−buildMakeActions :: FilePath -- ^ the output directory

317− -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module

318− -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module

319− -> Bool -- ^ Generate a prefix comment?

320− -> MakeActions Make

305+-- | A set of make actions that read and write modules from the given directory.

306+buildMakeActions

307+ :: FilePath

308+ -- ^ the output directory

309+ -> M.Map ModuleName (Either RebuildPolicy FilePath)

310+ -- ^ a map between module names and paths to the file containing the PureScript module

311+ -> M.Map ModuleName FilePath

312+ -- ^ a map between module name and the file containing the foreign javascript for the module

313+ -> Bool

314+ -- ^ Generate a prefix comment?

315+ -> MakeActions Make

321316buildMakeActions outputDir filePathMap foreigns usePrefix =

322− MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

317+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

323318 where

324319

325320 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

@@ -421,10 +416,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

421416 progress :: ProgressMessage -> Make ()

422417 progress = liftIO . putStrLn . renderProgressMessage

423418

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

426420-- in its corresponding foreign module.

427−--

428421checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

429422checkForeignDecls m path = do

430423 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

3−--

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

42module Language.PureScript.ModuleDependencies

53 ( sortModules

64 , ModuleGraph

75 ) where

9−import Prelude.Compat

10−

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

12−

13−import Data.Graph

14−import Data.List (nub)

15−import Data.Maybe (fromMaybe)

7+import Protolude

168

17−import Language.PureScript.AST

18−import Language.PureScript.Crash

19−import Language.PureScript.Errors

20−import Language.PureScript.Names

21−import Language.PureScript.Types

9+import Data.Graph

10+import qualified Data.Set as S

11+import Language.PureScript.AST

12+import qualified Language.PureScript.Constants as C

13+import Language.PureScript.Crash

14+import Language.PureScript.Errors

15+import Language.PureScript.Names

2216

2317-- | A list of modules with their transitive dependencies

2418type ModuleGraph = [(ModuleName, [ModuleName])]

@@ -26,75 +20,45 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

2620-- | Sort a collection of modules based on module dependencies.

2721--

2822-- Reports an error if the module graph contains a cycle.

29−--

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

23+sortModules

24+ :: forall m

25+ . MonadError MultipleErrors m

26+ => [Module]

27+ -> m ([Module], ModuleGraph)

3128sortModules ms = do

32− let verts = map goModule ms

33− ms' <- mapM toModule $ stronglyConnComp verts

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

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

36− let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

37− deps = reachable graph v

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

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

40− return (ms', moduleGraph)

29+ let mns = S.fromList $ map getModuleName ms

30+ verts <- mapM (toGraphNode mns) ms

31+ ms' <- mapM toModule $ stronglyConnComp verts

32+ let (graph, fromVertex, toVertex) = graphFromEdges verts

33+ moduleGraph = do (_, mn, _) <- verts

34+ let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

35+ deps = reachable graph v

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

37+ return (mn, filter (/= mn) (map toKey deps))

38+ return (ms', moduleGraph)

4139 where

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

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

44− let ams = concatMap extractQualAs ds

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

40+ toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])

41+ toGraphNode mns m@(Module _ _ mn ds _) = do

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

46+ pure (m, getModuleName m, deps)

4647

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

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

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

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

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

59−--

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

61−usedModules ams d =

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

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

64− in nub (f d ++ g d)

65− where

48+-- | Calculate a list of used modules based on explicit imports and qualified names.

49+usedModules :: Declaration -> [ModuleName]

50+usedModules d = f d where

51+ f :: Declaration -> [ModuleName]

52+ (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const [])

6653

6754 forDecls :: Declaration -> [ModuleName]

68− forDecls (ImportDeclaration mn _ _) =

69− -- Regardless of whether an imported module is qualified we still need to

70− -- take into account its import to build an accurate list of dependencies.

71− [mn]

72− forDecls (FixityDeclaration fd)

73− | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]

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

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

55+ -- Regardless of whether an imported module is qualified we still need to

56+ -- take into account its import to build an accurate list of dependencies.

57+ forDecls (ImportDeclaration mn _ _) = [mn]

7658 forDecls _ = []

7759

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

96−--

97−toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module

60+-- | Convert a strongly connected component of the module graph to a module

61+toModule :: MonadError MultipleErrors m => SCC Module -> m Module

9862toModule (AcyclicSCC m) = return m

9963toModule (CyclicSCC [m]) = return m

10064toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

src/Language/PureScript/Parser/Common.hs+49−73

@@ -1,52 +1,39 @@

1−-- |

2−-- Constants and utility functions to be used when parsing

3−--

1+-- | Useful common functions for building parsers

42module Language.PureScript.Parser.Common where

6−import Prelude.Compat

4+import Prelude.Compat

8−import Control.Applicative ((<|>))

9−import Control.Monad (guard)

10−import Data.Monoid ((<>))

11−import Data.Text (Text)

6+import Control.Applicative ((<|>))

7+import Control.Monad (guard)

8+import Data.Maybe (fromMaybe)

9+import Data.Monoid ((<>))

10+import Data.Text (Text)

1211import qualified Data.Text as T

13−

14−import Language.PureScript.AST.SourcePos

15−import Language.PureScript.Comments

16−import Language.PureScript.Names

17−import Language.PureScript.Parser.Lexer

18−import Language.PureScript.Parser.State

19−import Language.PureScript.PSString (PSString, mkString)

20−

12+import Language.PureScript.AST.SourcePos

13+import Language.PureScript.Comments

14+import Language.PureScript.Names

15+import Language.PureScript.Parser.Lexer

16+import Language.PureScript.Parser.State

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

2118import qualified Text.Parsec as P

2219

23−-- |

24−-- Parse a general proper name.

25−--

20+-- | Parse a general proper name.

2621properName :: TokenParser (ProperName a)

2722properName = ProperName <$> uname

2823

29−-- |

30−-- Parse a proper name for a type.

31−--

24+-- | Parse a proper name for a type.

3225typeName :: TokenParser (ProperName 'TypeName)

3326typeName = ProperName <$> tyname

3427

35−-- |

36−-- Parse a proper name for a kind.

37−--

28+-- | Parse a proper name for a kind.

3829kindName :: TokenParser (ProperName 'KindName)

3930kindName = ProperName <$> kiname

4031

41−-- |

42−-- Parse a proper name for a data constructor.

43−--

32+-- | Parse a proper name for a data constructor.

4433dataConstructorName :: TokenParser (ProperName 'ConstructorName)

4534dataConstructorName = ProperName <$> dconsname

4635

47−-- |

48−-- Parse a module name

49−--

36+-- | Parse a module name

5037moduleName :: TokenParser ModuleName

5138moduleName = part []

5239 where

@@ -55,9 +42,7 @@ moduleName = part []

5542 <|> (ModuleName . snoc path . ProperName <$> mname)

5643 snoc path name = path ++ [name]

5744

58−-- |

59−-- Parse a qualified name, i.e. M.name or just name

60−--

45+-- | Parse a qualified name, i.e. M.name or just name

6146parseQualified :: TokenParser a -> TokenParser (Qualified a)

6247parseQualified parser = part []

6348 where

@@ -67,42 +52,30 @@ parseQualified parser = part []

6752 updatePath path name = path ++ [name]

6853 qual path = if null path then Nothing else Just $ ModuleName path

6954

70−-- |

71−-- Parse an identifier.

72−--

55+-- | Parse an identifier.

7356parseIdent :: TokenParser Ident

7457parseIdent = Ident <$> identifier

7558

76−-- |

77−-- Parse a label, which may look like an identifier or a string

78−--

59+-- | Parse a label, which may look like an identifier or a string

7960parseLabel :: TokenParser PSString

8061parseLabel = (mkString <$> lname) <|> stringLiteral

8162

82−-- |

83−-- Parse an operator.

84−--

63+-- | Parse an operator.

8564parseOperator :: TokenParser (OpName a)

8665parseOperator = OpName <$> symbol

8766

88−-- |

89−-- Run the first parser, then match the second if possible, applying the specified function on a successful match

90−--

67+-- | Run the first parser, then match the second if possible, applying the specified function on a successful match

9168augment :: 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

9269augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

9370

94−-- |

95−-- Run the first parser, then match the second zero or more times, applying the specified function for each match

96−--

71+-- | Run the first parser, then match the second zero or more times, applying the specified function for each match

9772fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

9873fold first' more combine = do

9974 a <- first'

10075 bs <- P.many more

10176 return $ foldl combine a bs

10277

103−-- |

104−-- Build a parser from a smaller parser and a list of parsers for postfix operators

105−--

78+-- | Build a parser from a smaller parser and a list of parsers for postfix operators

10679buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

10780buildPostfixParser fs first' = do

10881 a <- first'

@@ -114,9 +87,7 @@ buildPostfixParser fs first' = do

11487 Nothing -> return a

11588 Just a' -> go a'

11689

117−-- |

118−-- Mark the current indentation level

119−--

90+-- | Mark the current indentation level

12091mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a

12192mark p = do

12293 current <- indentationLevel <$> P.getState

@@ -126,9 +97,7 @@ mark p = do

12697 P.modifyState $ \st -> st { indentationLevel = current }

12798 return a

12899

129−-- |

130−-- Check that the current identation level matches a predicate

131−--

100+-- | Check that the current identation level matches a predicate

132101checkIndentation

133102 :: (P.Column -> Text)

134103 -> (P.Column -> P.Column -> Bool)

@@ -138,32 +107,39 @@ checkIndentation mkMsg rel = do

138107 current <- indentationLevel <$> P.getState

139108 guard (col `rel` current) P.<?> T.unpack (mkMsg current)

140109

141−-- |

142−-- Check that the current indentation level is past the current mark

143−--

110+-- | Check that the current indentation level is past the current mark

144111indented :: P.Parsec s ParseState ()

145112indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)

146113

147−-- |

148−-- Check that the current indentation level is at the same indentation as the current mark

149−--

114+-- | Check that the current indentation level is at the same indentation as the current mark

150115same :: P.Parsec s ParseState ()

151116same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)

152117

153−-- |

154−-- Read the comments from the the next token, without consuming it

155−--

118+-- | Read the comments from the the next token, without consuming it

156119readComments :: P.Parsec [PositionedToken] u [Comment]

157120readComments = P.lookAhead $ ptComments <$> P.anyToken

158121

159−-- |

160−-- Run a parser

161−--

122+-- | Run a parser

162123runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a

163124runTokenParser filePath p = P.runParser p (ParseState 0) filePath

164125

165−-- |

166−-- Convert from Parsec sourcepos

167−--

126+-- | Convert from Parsec sourcepos

168127toSourcePos :: P.SourcePos -> SourcePos

169128toSourcePos 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

3−--

1+-- | Parsers for module definitions and declarations

42module Language.PureScript.Parser.Declarations

53 ( parseDeclaration

64 , parseModule

@@ -15,53 +13,32 @@ module Language.PureScript.Parser.Declarations

1513 , toPositionedError

1614 ) where

1715

18−import Prelude hiding (lex)

19−

20−import Data.Functor (($>))

21−import Data.Maybe (fromMaybe)

22−import Data.Text (Text)

23−

24−import Control.Applicative

25−import Control.Arrow ((+++))

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

27−import Control.Parallel.Strategies (withStrategy, parList, rseq)

28−

29−import Language.PureScript.AST

30−import Language.PureScript.Comments

31−import Language.PureScript.Environment

32−import Language.PureScript.Errors

33−import Language.PureScript.Kinds

34−import Language.PureScript.Names

35−import Language.PureScript.Types

36−import Language.PureScript.PSString (PSString, mkString)

37−import Language.PureScript.Parser.Common

38−import Language.PureScript.Parser.Kinds

39−import Language.PureScript.Parser.Lexer

40−import Language.PureScript.Parser.Types

41−

42−import qualified Language.PureScript.Parser.Common as C

16+import Prelude hiding (lex)

17+

18+import Control.Applicative

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

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

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

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)

28+import Language.PureScript.AST

29+import Language.PureScript.Environment

30+import Language.PureScript.Errors

31+import Language.PureScript.Kinds

32+import Language.PureScript.Names

33+import Language.PureScript.Parser.Common

34+import Language.PureScript.Parser.Kinds

35+import Language.PureScript.Parser.Lexer

36+import Language.PureScript.Parser.Types

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

38+import Language.PureScript.Types

4339import qualified Text.Parsec as P

4440import qualified Text.Parsec.Expr as P

4541

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−

6542kindedIdent :: TokenParser (Text, Maybe Kind)

6643kindedIdent = (, Nothing) <$> identifier

6744 <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

@@ -91,7 +68,7 @@ parseValueDeclaration :: TokenParser Declaration

9168parseValueDeclaration = do

9269 name <- parseIdent

9370 binders <- P.many parseBinderNoParens

94− value <- Left <$> (C.indented *>

71+ value <- Left <$> (indented *>

9572 P.many1 ((,) <$> parseGuard

9673 <*> (indented *> equals *> parseValueWithWhereClause)

9774 ))

@@ -100,13 +77,13 @@ parseValueDeclaration = do

10077 where

10178 parseValueWithWhereClause :: TokenParser Expr

10279 parseValueWithWhereClause = do

103− C.indented

80+ indented

10481 value <- parseValue

10582 whereClause <- P.optionMaybe $ do

106− C.indented

83+ indented

10784 reserved "where"

108− C.indented

109− C.mark $ P.many1 (C.same *> parseLocalDeclaration)

85+ indented

86+ mark $ P.many1 (same *> parseLocalDeclaration)

11087 return $ maybe value (`Let` value) whereClause

11188

11289parseExternDeclaration :: TokenParser Declaration

@@ -237,9 +214,7 @@ parseDerivingInstanceDeclaration = do

237214positioned :: TokenParser Declaration -> TokenParser Declaration

238215positioned = withSourceSpan PositionedDeclaration

239216

240−-- |

241−-- Parse a single declaration

242−--

217+-- | Parse a single declaration

243218parseDeclaration :: TokenParser Declaration

244219parseDeclaration = positioned (P.choice

245220 [ parseDataDeclaration

@@ -259,12 +234,10 @@ parseLocalDeclaration = positioned (P.choice

259234 , parseValueDeclaration

260235 ] P.<?> "local declaration")

261236

262−-- |

263−-- Parse a module header and a collection of declarations

264−--

237+-- | Parse a module header and a collection of declarations

265238parseModule :: TokenParser Module

266239parseModule = do

267− comments <- C.readComments

240+ comments <- readComments

268241 start <- P.getPosition

269242 reserved "module"

270243 indented

@@ -280,7 +253,7 @@ parseModule = do

280253 return (imports ++ decls)

281254 _ <- P.eof

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

284257 return $ Module ss comments name decls exports

285258

286259-- | Parse a collection of modules in parallel

@@ -301,7 +274,6 @@ parseModulesFromFiles toFilePath input =

301274 inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)]

302275 inParallel = withStrategy (parList rseq)

303276

304−

305277-- | Parses a single module with FilePath for eventual parsing errors

306278parseModuleFromFile

307279 :: (k -> FilePath)

@@ -313,12 +285,12 @@ parseModuleFromFile toFilePath (k, content) = do

313285 m <- runTokenParser filename parseModule ts

314286 pure (k, m)

315287

316−-- | Converts a @ParseError@ into a @PositionedError@

288+-- | Converts a 'ParseError' into a 'PositionedError'

317289toPositionedError :: P.ParseError -> ErrorMessage

318290toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)

319291 where

320292 name = (P.sourceName . P.errorPos) perr

321− start = (C.toSourcePos . P.errorPos) perr

293+ start = (toSourcePos . P.errorPos) perr

322294 end = start

323295

324296booleanLiteral :: TokenParser Bool

@@ -345,18 +317,18 @@ parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

345317parseIdentifierAndValue :: TokenParser (PSString, Expr)

346318parseIdentifierAndValue =

347319 do

348− name <- C.indented *> lname

320+ name <- indented *> lname

349321 b <- P.option (Var $ Qualified Nothing (Ident name)) rest

350322 return (mkString name, b)

351− <|> (,) <$> (C.indented *> stringLiteral) <*> rest

323+ <|> (,) <$> (indented *> stringLiteral) <*> rest

352324 where

353− rest = C.indented *> colon *> C.indented *> parseValue

325+ rest = indented *> colon *> indented *> parseValue

354326

355327parseAbs :: TokenParser Expr

356328parseAbs = do

357329 symbol' "\\"

358− args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens)))

359− C.indented *> rarrow

330+ args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens)))

331+ indented *> rarrow

360332 value <- parseValue

361333 return $ toFunction args value

362334 where

@@ -364,18 +336,18 @@ parseAbs = do

364336 toFunction args value = foldr ($) value args

365337

366338parseVar :: TokenParser Expr

367−parseVar = Var <$> C.parseQualified C.parseIdent

339+parseVar = Var <$> parseQualified parseIdent

368340

369341parseConstructor :: TokenParser Expr

370−parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName

342+parseConstructor = Constructor <$> parseQualified dataConstructorName

371343

372344parseCase :: TokenParser Expr

373−parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

374− <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

345+parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue)

346+ <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative)))

375347

376348parseCaseAlternative :: TokenParser CaseAlternative

377349parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

378− <*> (Left <$> (C.indented *>

350+ <*> (Left <$> (indented *>

379351 P.many1 ((,) <$> parseGuard

380352 <*> (indented *> rarrow *> parseValue)

381353 ))

@@ -383,16 +355,16 @@ parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder

383355 P.<?> "case alternative"

384356

385357parseIfThenElse :: TokenParser Expr

386−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)

387− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)

388− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)

358+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue)

359+ <*> (indented *> reserved "then" *> indented *> parseValue)

360+ <*> (indented *> reserved "else" *> indented *> parseValue)

389361

390362parseLet :: TokenParser Expr

391363parseLet = do

392364 reserved "let"

393− C.indented

394− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)

395− C.indented

365+ indented

366+ ds <- mark $ P.many1 (same *> parseLocalDeclaration)

367+ indented

396368 reserved "in"

397369 result <- parseValue

398370 return $ Let ds result

@@ -418,9 +390,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice

418390 , parseHole

419391 ]

420392

421−-- |

422−-- Parse an expression in backticks or an operator

423−--

393+-- | Parse an expression in backticks or an operator

424394parseInfixExpr :: TokenParser Expr

425395parseInfixExpr

426396 = P.between tick tick parseValue

@@ -429,28 +399,29 @@ parseInfixExpr

429399parseHole :: TokenParser Expr

430400parseHole = Hole <$> holeLit

431401

432−parsePropertyUpdate :: TokenParser (PSString, Expr)

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

433403parsePropertyUpdate = do

434404 name <- parseLabel

435− _ <- C.indented *> equals

436− value <- C.indented *> parseValue

437− return (name, value)

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

406+ _ <- indented *> equals

407+ value <- indented *> parseValue

408+ return (name :| rest, value)

438409

439410parseAccessor :: Expr -> TokenParser Expr

440411parseAccessor (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

442413

443414parseDo :: TokenParser Expr

444415parseDo = do

445416 reserved "do"

446− C.indented

447− Do <$> C.mark (P.many1 (C.same *> C.mark parseDoNotationElement))

417+ indented

418+ Do <$> mark (P.many1 (same *> mark parseDoNotationElement))

448419

449420parseDoNotationLet :: 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)))

451422

452423parseDoNotationBind :: TokenParser DoNotationElement

453−parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue

424+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue

454425

455426parseDoNotationElement :: TokenParser DoNotationElement

456427parseDoNotationElement = P.choice

@@ -461,33 +432,34 @@ parseDoNotationElement = P.choice

461432

462433-- | Expressions including indexers and record updates

463434indexersAndAccessors :: TokenParser Expr

464−indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

435+indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom

465436 where

466437 postfixTable = [ parseAccessor

467438 , P.try . parseUpdaterBody

468439 ]

469440

470−-- |

471−-- Parse a value

472−--

441+-- | Parse an expression

473442parseValue :: TokenParser Expr

474443parseValue = withSourceSpan PositionedValue

475444 (P.buildExpressionParser operators

476− . C.buildPostfixParser postfixTable

445+ . buildPostfixParser postfixTable

477446 $ indexersAndAccessors) P.<?> "expression"

478447 where

479− postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

480− , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v

448+ postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v

449+ , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v

481450 ]

482− operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)

451+ operators = [ [ P.Prefix (indented *> symbol' "-" *> return UnaryMinus)

483452 ]

484− , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

453+ , [ P.Infix (P.try (indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

485454 return (BinaryNoParens ident)) P.AssocRight

486455 ]

487456 ]

488457

489458parseUpdaterBody :: 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

491463

492464parseAnonymousArgument :: TokenParser Expr

493465parseAnonymousArgument = underscore *> pure AnonymousArgument

@@ -501,21 +473,21 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

501473 <|> return id

502474

503475parseNullaryConstructorBinder :: TokenParser Binder

504−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []

476+parseNullaryConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> pure []

505477

506478parseConstructorBinder :: TokenParser Binder

507−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)

479+parseConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> many (indented *> parseBinderNoParens)

508480

509481parseObjectBinder:: TokenParser Binder

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

482+parseObjectBinder = LiteralBinder <$> parseObjectLiteral (indented *> parseIdentifierAndBinder)

511483

512484parseArrayBinder :: TokenParser Binder

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

485+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder)

514486

515487parseVarOrNamedBinder :: TokenParser Binder

516488parseVarOrNamedBinder = do

517− name <- C.parseIdent

518− let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)

489+ name <- parseIdent

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

519491 parseNamedBinder <|> return (VarBinder name)

520492

521493parseNullBinder :: TokenParser Binder

@@ -528,11 +500,9 @@ parseIdentifierAndBinder =

528500 return (mkString name, b)

529501 <|> (,) <$> stringLiteral <*> rest

530502 where

531− rest = C.indented *> colon *> C.indented *> parseBinder

503+ rest = indented *> colon *> indented *> parseBinder

532504

533−-- |

534−-- Parse a binder

535−--

505+-- | Parse a binder

536506parseBinder :: TokenParser Binder

537507parseBinder =

538508 withSourceSpan

@@ -543,7 +513,7 @@ parseBinder =

543513 )

544514 where

545515 operators =

546− [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

516+ [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

547517 return (BinaryNoParensBinder op)) P.AssocRight

548518 ]

549519 ]

@@ -569,9 +539,7 @@ parseBinderAtom = P.choice

569539 , ParensInBinder <$> parens parseBinder

570540 ] P.<?> "binder"

571541

572−-- |

573−-- Parse a binder as it would appear in a top level declaration

574−--

542+-- | Parse a binder as it would appear in a top level declaration

575543parseBinderNoParens :: TokenParser Binder

576544parseBinderNoParens = P.choice

577545 [ parseNullBinder

@@ -586,8 +554,6 @@ parseBinderNoParens = P.choice

586554 , ParensInBinder <$> parens parseBinder

587555 ] P.<?> "binder"

588556

589−-- |

590−-- Parse a guard

591−--

557+-- | Parse a guard

592558parseGuard :: TokenParser Guard

593−parseGuard = pipe *> C.indented *> parseValue

559+parseGuard = pipe *> indented *> parseValue

src/Language/PureScript/Pretty/Cpp.hs+1

@@ -20,6 +20,7 @@ module Language.PureScript.Pretty.Cpp

2020 ( dotsTo

2121 , linebreak

2222 , prettyPrintCpp

23+ , prettyPrintCpp1

2324 , utf16Text

2425 ) where

2526

src/Language/PureScript/Pretty/JS.hs+7−5

@@ -159,11 +159,13 @@ conditional = mkPattern match

159159 match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

160160 match _ = Nothing

161161

162−accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

162+accessor :: Pattern PrinterState JS (Text, JS)

163163accessor = mkPattern match

164164 where

165− -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513

166− match (JSAccessor _ prop val) = Just (emit prop, val)

165+ match (JSIndexer _ (JSStringLiteral _ prop) val) =

166+ case decodeString prop of

167+ Just s | not (identNeedsEscaping s) -> Just (s, val)

168+ _ -> Nothing

167169 match _ = Nothing

168170

169171indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

@@ -257,8 +259,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

257259 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

258260 operators :: (Emit gen) => OperatorTable PrinterState JS gen

259261 operators =

260− OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]

261− , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

262+ OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

263+ , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]

262264 , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

263265 , [ unary JSNew "new " ]

264266 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

src/Language/PureScript/Pretty/Values.hs+11−1

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

1212import Control.Arrow (second)

1313

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

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

1516

1617import qualified Data.Text as T

1718import Data.Text (Text)

@@ -47,6 +48,12 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

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

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

4950

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+

5057-- | Pretty-print an expression

5158prettyPrintValue :: Int -> Expr -> Box

5259prettyPrintValue d _ | d < 0 = text "..."

@@ -56,7 +63,10 @@ prettyPrintValue d (IfThenElse cond th el) =

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

5764 ])

5865prettyPrintValue 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)

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

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

6272prettyPrintValue 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

1616 , checkCleanWorkingTree

1717 , getVersionFromGitTag

1818 , getBowerRepositoryInfo

19− , getModulesAndBookmarks

19+ , getModules

2020 , getResolvedDependencies

2121 ) where

2222

23−import Prelude ()

24−import Prelude.Compat hiding (userError)

23+import Protolude hiding (stdin)

2524

26−import Control.Arrow ((***), first)

25+import Control.Arrow ((***))

2726import Control.Category ((>>>))

28−import Control.Exception (catch, try)

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

30−import Control.Monad.Trans.Except

3127import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

32−import Control.Monad.Writer.Strict

28+import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)

3329

3430import Data.Aeson.BetterErrors

3531import Data.Char (isSpace)

36−import Data.Foldable (traverse_)

37−import Data.Function (on)

32+import Data.String (String, lines)

3833import Data.List (stripPrefix, (\\), nubBy)

3934import Data.List.NonEmpty (NonEmpty(..))

4035import Data.List.Split (splitOn)

41−import Data.Maybe

42−import Data.Text (Text)

4336import qualified Data.Text as T

4437import qualified Data.Text.Lazy as TL

4538import qualified Data.Text.Lazy.Encoding as TL

@@ -47,10 +40,7 @@ import Data.Time.Clock (UTCTime)

4740import Data.Version

4841import qualified Data.SPDX as SPDX

4942

50−import Safe (headMay)

51−

5243import System.Directory (doesFileExist, findExecutable)

53−import System.Exit (exitFailure)

5444import System.FilePath (pathSeparator)

5545import System.Process (readProcess)

5646import qualified System.FilePath.Glob as Glob

@@ -61,7 +51,7 @@ import qualified Web.Bower.PackageMeta as Bower

6151

6252import Language.PureScript.Publish.ErrorsWarnings

6353import Language.PureScript.Publish.Utils

64−import qualified Language.PureScript as P (version)

54+import qualified Language.PureScript as P (version, ModuleName)

6555import qualified Language.PureScript.Docs as D

6656

6757data PublishOptions = PublishOptions

@@ -129,9 +119,6 @@ otherError = throwError . OtherError

129119catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b

130120catchLeft a f = either f pure a

131121

132−unlessM :: Monad m => m Bool -> m () -> m ()

133−unlessM cond act = cond >>= flip unless act

134−

135122preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage

136123preparePackage' opts = do

137124 unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)

@@ -144,7 +131,7 @@ preparePackage' opts = do

144131 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

145132 pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag

146133 pkgGithub <- getBowerRepositoryInfo pkgMeta

147− (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

134+ (pkgModules, pkgModuleMap) <- getModules

148135

149136 let declaredDeps = map fst (bowerDependencies pkgMeta ++

150137 bowerDevDependencies pkgMeta)

@@ -155,18 +142,18 @@ preparePackage' opts = do

155142

156143 return D.Package{..}

157144

158−getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

159−getModulesAndBookmarks = do

145+getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName)

146+getModules = do

160147 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

161− (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles

148+ (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles

162149

163− case runExcept (D.convertModulesInPackage modules') of

164− Right modules -> return (bookmarks, modules)

150+ case runExcept (D.convertModulesInPackage modules' moduleMap) of

151+ Right modules -> return (modules, moduleMap)

165152 Left err -> userError (CompileError err)

166153

167154 where

168− parseAndBookmark inputFiles depsFiles = do

169− r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles

155+ parseFilesInPackages inputFiles depsFiles = do

156+ r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles

170157 case r of

171158 Right r' ->

172159 return r'

src/Language/PureScript/Sugar/ObjectWildcards.hs+99−16

@@ -3,19 +3,48 @@ module Language.PureScript.Sugar.ObjectWildcards

33 , desugarDecl

44 ) where

6−import Prelude.Compat

6+import Prelude.Compat

8−import Control.Monad (forM)

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

10−import Control.Monad.Supply.Class

8+import Control.Monad (forM, foldM)

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

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)

1122

12−import Data.List (partition)

13−import Data.Maybe (catMaybes)

14−

15−import Language.PureScript.AST

16−import Language.PureScript.Errors

17−import Language.PureScript.Names

18−import Language.PureScript.PSString (PSString)

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

24+-- For an update such as:

25+--

26+-- x { foo = 0

27+-- , bar.baz = 1

28+-- , bar.qux = 2 }

29+--

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

31+--

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

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

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

35+--

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

37+--

38+-- let x' = x

39+-- in x' { foo = 0

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

41+-- , qux = 2 } }

42+--

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

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

45+--

46+type PathTree = Map PSString PathNode

47+data PathNode = Leaf Expr | Branch PathTree

1948

2049desugarObjectConstructors

2150 :: forall m

@@ -46,6 +75,7 @@ desugarDecl other = fn other

4675 obj <- freshIdent'

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

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

78+ desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

4979 desugarExpr (Accessor prop u)

5080 | Just props <- peelAnonAccessorChain u = do

5181 arg <- freshIdent'

@@ -62,14 +92,67 @@ desugarDecl other = fn other

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

6393 desugarExpr e = return e

6494

65− wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr

66− wrapLambda mkVal ps =

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

145+ wrapLambdaM mkVal ps =

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

68147 in if null args

69− then return $ mkVal props

148+ then mkVal props

70149 else do

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

72− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

151+ val <- mkVal ps'

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)

73156

74157 stripPositionInfo :: Expr -> Expr

75158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

@@ -86,7 +169,7 @@ desugarDecl other = fn other

86169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

87170 isAnonymousArgument _ = False

88171

89− mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))

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

90173 mkProp (name, e) = do

91174 arg <- freshIfAnon e

92175 return (arg, (name, maybe e argToExpr arg))

src/Language/PureScript/TypeChecker.hs+8

@@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go

297297 case M.lookup className (typeClasses env) of

298298 Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"

299299 Just typeClass -> do

300+ checkInstanceArity dictName className typeClass tys

300301 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301302 checkOrphanInstance dictName className typeClass tys

302303 _ <- traverseTypeInstanceBody checkInstanceMembers body

@@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go

306307 go (PositionedDeclaration pos com d) =

307308 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

308309

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+

309317 checkInstanceMembers :: [Declaration] -> m [Declaration]

310318 checkInstanceMembers instDecls = do

311319 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

4545data Evidence

4646 = NamedInstance (Qualified Ident)

4747 -- ^ An existing named instance

48+ | WarnInstance Type

49+ -- ^ Computed instance of the Warn type class with a user-defined warning message

4850 | IsSymbolInstance PSString

4951 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

5052 | CompareSymbolInstance

@@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints =

144146 solve constraint

145147 where

146148 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

149+ forClassName _ C.Warn [msg] =

150+ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]

147151 forClassName _ C.IsSymbol [TypeLevelString sym] =

148152 [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

149153 forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

@@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints =

216220 let subst'' = fmap (substituteType currentSubst') subst'

217221 -- Solve any necessary subgoals

218222 args <- solveSubgoals subst'' (tcdDependencies tcd)

223+ initDict <- lift . lift $ mkDictionary (tcdValue tcd) args

219224 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

220− (mkDictionary (tcdValue tcd) args)

225+ initDict

221226 (tcdPath tcd)

222227 return match

223228 Unsolved unsolved -> do

@@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints =

308313 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

309314

310315 -- Make a dictionary from subgoal dictionaries by applying the correct function

311− mkDictionary :: Evidence -> Maybe [Expr] -> Expr

312− mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

316+ mkDictionary :: Evidence -> Maybe [Expr] -> m Expr

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

313321 mkDictionary (IsSymbolInstance sym) _ =

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

316324 mkDictionary CompareSymbolInstance _ =

317− TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

325+ return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

318326 mkDictionary AppendSymbolInstance _ =

319− TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

327+ return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

320328

321329 -- Turn a DictionaryValue into a Expr

322330 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

src/Language/PureScript/TypeChecker/Types.hs+18−12

@@ -77,11 +77,11 @@ typesOf

7777 -> [(Ident, Expr)]

7878 -> m [(Ident, (Expr, Type))]

7979typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

80− tys <- capturingSubstitution tidyUp $ do

81− SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals

80+ (tys, wInfer) <- capturingSubstitution tidyUp $ do

81+ (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals

8282 ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict

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

8585

8686 inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do

8787 -- Replace type class dictionary placeholders with actual dictionaries

@@ -123,10 +123,13 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

123123 -- Show warnings here, since types in wildcards might have been solved during

124124 -- instance resolution (by functional dependencies).

125125 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

126131 forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do

127− let replaceTypes' = replaceTypes (checkSubstitution finalState)

128− runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState

129− (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w

132+ raisePreviousWarnings shouldGeneralize w

130133

131134 return (map fst inferred)

132135 where

@@ -160,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

160163 constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)

161164

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

164167

165168 isHoleError :: ErrorMessage -> Bool

166169 isHoleError (ErrorMessage _ HoleInferredType{}) = True

@@ -187,7 +190,7 @@ data SplitBindingGroup = SplitBindingGroup

187190-- This function also generates fresh unification variables for the types of

188191-- declarations without type annotations, returned in the 'UntypedData' structure.

189192typeDictionaryForBindingGroup

190− :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

193+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)

191194 => Maybe ModuleName

192195 -> [(Ident, Expr)]

193196 -> m SplitBindingGroup

@@ -197,7 +200,7 @@ typeDictionaryForBindingGroup moduleName vals = do

197200 -- fully expanded types.

198201 let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)

199202 (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do

200− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

203+ ty' <- replaceTypeWildcards ty

201204 return ((ident, ty'), (ident, (expr, ty', checkType)))

202205 -- Create fresh unification variables for the types of untyped declarations

203206 (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do

@@ -233,11 +236,14 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do

233236 -- Kind check

234237 (kind, args) <- kindOfWithScopedVars ty

235238 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

236242 -- Check the type with the new names in scope

237243 val' <- if checkType

238− then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty

239− else return (TypedValue False val ty)

240− return (ident, (val', ty))

244+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty'

245+ else return (TypedValue False val ty')

246+ return (ident, (val', ty'))

241247

242248-- | Infer a type for a value in a binding group which lacks an annotation.

243249typeForBindingGroupElement

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

@@ -243,7 +243,7 @@ unwrapResult = withObject "result" $ \o -> do

243243 case rt of

244244 "error" -> do

245245 res <- o .: "result"

246− pure (Left res)

246+ withArray "errors" (fmap (Left . fold) . traverse (withObject "error" (.: "message"))) res

247247 "success" -> do

248248 res <- o .: "result"

249249 pure (Right res)