bf6cda5 · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

commitbf6cda50d8c078812f21be6e3c95dfae0afae65f authorAndy Arvanitis <andyarvanitis@gmail.com> dateThu 10 Dec 2015, 20:29 (11 years ago) parent9264ef4 dccc7af

32 files changed+844−348

compare with golang

unifiedsplit

CONTRIBUTORS.md+1

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

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

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

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

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

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

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

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

examples/failing/IntOutOfRange.pursnew file+6

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

1+-- @shouldFailWith IntOutOfRange

3+module Main where

5+n :: Int

6+n = 35028715023

examples/passing/1185.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+data Person = Person String Boolean

5+getName :: Person -> String

6+getName p = case p of

7+ Person name true -> name

8+ _ -> "Unknown"

10+name :: String

11+name = getName (Person "John Smith" true)

12+

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

examples/passing/1664.pursnew file+16

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

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

7+data Identity a = Identity a

9+newtype IdentityEff e a = IdentityEff (Eff e (Identity a))

10+

11+test :: forall e a. IdentityEff e a -> IdentityEff e Unit

12+test (IdentityEff action) = IdentityEff $ do

13+ (Identity x :: Identity _) <- action

14+ return $ Identity unit

15+

16+main = log "Done"

examples/passing/ClassRefSyntax.pursnew file+13

@@ -0,0 +1,13 @@

1+module Lib (class X, go) where

3+ class X a where

4+ go :: a -> a

6+module Main where

8+ import Lib (class X, go)

10+ go' :: forall a. (X a) => a -> a

11+ go' = go

12+

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

examples/passing/ShadowedModuleName.pursnew file+15

@@ -0,0 +1,15 @@

1+module Test where

3+ data Z = Z String

5+ runZ :: Z -> String

6+ runZ (Z s) = s

8+module Main where

10+ import Test

11+ import Control.Monad.Eff.Console

12+

13+ data Test = Test

14+

15+ main = log (runZ (Z "done"))

examples/passing/TypeWithoutParens.pursnew file+16

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

1+module Lib (X, Y) where

3+ data X = X

4+ type Y = X

6+module Main where

8+ import Lib (X, Y)

10+ idX :: X -> X

11+ idX x = x

12+

13+ idY :: Y -> Y

14+ idY y = y

15+

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

psc-bundle/Main.hs+1−1

@@ -70,7 +70,7 @@ app Options{..} = do

7070 input <- for inputFiles $ \filename -> do

7171 js <- liftIO (readFile filename)

7272 mid <- guessModuleIdentifier filename

73− return (mid, js)

73+ length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles

7474

7575 let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints

7676

psc-docs/Tags.hs+3−3

@@ -10,9 +10,9 @@ tags = concatMap dtags . P.exportedDeclarations

1010 dtags _ = []

1111 names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames

1212 where consNames = map (\(cname, _) -> P.runProperName cname) dcons

13− names (P.TypeDeclaration ident _) = [show ident]

14− names (P.ExternDeclaration ident _) = [show ident]

13+ names (P.TypeDeclaration ident _) = [P.showIdent ident]

14+ names (P.ExternDeclaration ident _) = [P.showIdent ident]

1515 names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]

1616 names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]

17− names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]

17+ names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]

1818 names _ = []

psci/PSCi.hs+9−20

@@ -1,23 +1,11 @@

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

2−--

3−-- Module : PSCi

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- PureScript Compiler Interactive.

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE DoAndIfThenElse #-}

172{-# LANGUAGE GeneralizedNewtypeDeriving #-}

183{-# LANGUAGE RecordWildCards #-}

194{-# LANGUAGE TupleSections #-}

205

6+-- |

7+-- PureScript Compiler Interactive.

8+--

219module PSCi where

2210

2311import Prelude ()

@@ -333,11 +321,12 @@ handleShowImportedModules = do

333321 refsList refs = "(" ++ commaList (map showRef refs) ++ ")"

334322

335323 showRef :: P.DeclarationRef -> String

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

337− showRef (P.ValueRef ident) = show ident

338− showRef (P.TypeClassRef pn) = show pn

339− showRef (P.TypeInstanceRef ident) = show ident

340− showRef (P.ModuleRef name) = "module " ++ show name

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

325+ showRef (P.ValueRef ident) = N.runIdent ident

326+ showRef (P.TypeClassRef pn) = N.runProperName pn

327+ showRef (P.ProperRef pn) = N.runProperName pn

328+ showRef (P.TypeInstanceRef ident) = N.runIdent ident

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

341330 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

342331

343332 commaList :: [String] -> String

src/Language/PureScript/AST/Declarations.hs+36−16

@@ -1,27 +1,19 @@

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

2−--

3−-- Module : Language.PureScript.AST.Declarations

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Data types for modules and declarations

12−--

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

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162{-# LANGUAGE ScopedTypeVariables #-}

173{-# LANGUAGE TemplateHaskell #-}

4+{-# LANGUAGE LambdaCase #-}

185

6+-- |

7+-- Data types for modules and declarations

8+--

199module Language.PureScript.AST.Declarations where

2010

2111import Prelude ()

2212import Prelude.Compat

2313

2414import Data.Aeson.TH

15+import Data.List (nub, (\\))

16+import Data.Maybe (mapMaybe)

2517

2618import qualified Data.Data as D

2719import qualified Data.Map as M

@@ -74,6 +66,10 @@ data DeclarationRef

7466 --

7567 | ModuleRef ModuleName

7668 -- |

69+ -- An unspecified ProperName ref. This will be replaced with a TypeClassRef

70+ -- or TypeRef during name desugaring.

71+ | ProperRef ProperName

72+ -- |

7773 -- A declaration reference with source position information

7874 --

7975 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

@@ -84,15 +80,39 @@ instance Eq DeclarationRef where

8480 (ValueRef name) == (ValueRef name') = name == name'

8581 (TypeClassRef name) == (TypeClassRef name') = name == name'

8682 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

87− (ModuleRef name) == (ModuleRef name') = name == name'

83+ (ModuleRef name) == (ModuleRef name') = name == name'

84+ (ProperRef name) == (ProperRef name') = name == name'

8885 (PositionedDeclarationRef _ _ r) == r' = r == r'

8986 r == (PositionedDeclarationRef _ _ r') = r == r'

9087 _ == _ = False

9188

9289isModuleRef :: DeclarationRef -> Bool

90+isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

9391isModuleRef (ModuleRef _) = True

9492isModuleRef _ = False

9593

94+-- |

95+-- Finds duplicate values in a list of declaration refs. The returned values

96+-- are the duplicate refs with data constructors elided, and then a separate

97+-- list of duplicate data constructors.

98+--

99+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])

100+findDuplicateRefs refs =

101+ let positionless = stripPosInfo `map` refs

102+ simplified = simplifyTypeRefs `map` positionless

103+ dupeRefs = nub $ simplified \\ nub simplified

104+ dupeCtors = concat $ flip mapMaybe positionless $ \case

105+ TypeRef _ (Just dctors) ->

106+ let dupes = dctors \\ nub dctors

107+ in if null dupes then Nothing else Just dupes

108+ _ -> Nothing

109+ in (dupeRefs, dupeCtors)

110+ where

111+ stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref

112+ stripPosInfo other = other

113+ simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing

114+ simplifyTypeRefs other = other

115+

96116-- |

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

98118--

@@ -109,7 +129,7 @@ data ImportDeclarationType

109129 -- An import with a list of references to hide: `import M hiding (foo)`

110130 --

111131 | Hiding [DeclarationRef]

112− deriving (Show, Read, D.Data, D.Typeable)

132+ deriving (Eq, Show, Read, D.Data, D.Typeable)

113133

114134-- |

115135-- The data type of declarations

src/Language/PureScript/AST/Exported.hs+3

@@ -118,6 +118,9 @@ isExported (Just exps) decl = any (matches decl) exps

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

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

120120

121+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'

122+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'

123+

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

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

123126 matches _ _ = False

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

@@ -18,6 +18,10 @@ import Prelude ()

1818import Prelude.Compat

1919

2020import Data.Maybe (mapMaybe)

21+import Data.List (mapAccumL)

22+import Data.Foldable (fold)

23+import qualified Data.Set as S

24+

2125import Control.Monad

2226import Control.Arrow ((***), (+++), second)

2327

@@ -25,6 +29,7 @@ import Language.PureScript.AST.Binders

2529import Language.PureScript.AST.Declarations

2630import Language.PureScript.Types

2731import Language.PureScript.Traversals

32+import Language.PureScript.Names

2833

2934everywhereOnValues :: (Declaration -> Declaration) ->

3035 (Expr -> Expr) ->

@@ -389,6 +394,112 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

389394 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

390395 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

391396

397+everythingWithScope ::

398+ (Monoid r) =>

399+ (S.Set Ident -> Declaration -> r) ->

400+ (S.Set Ident -> Expr -> r) ->

401+ (S.Set Ident -> Binder -> r) ->

402+ (S.Set Ident -> CaseAlternative -> r) ->

403+ (S.Set Ident -> DoNotationElement -> r) ->

404+ ( S.Set Ident -> Declaration -> r

405+ , S.Set Ident -> Expr -> r

406+ , S.Set Ident -> Binder -> r

407+ , S.Set Ident -> CaseAlternative -> r

408+ , S.Set Ident -> DoNotationElement -> r)

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

410+ where

411+ -- Avoid importing Data.Monoid and getting shadowed names above

412+ (<>) = mappend

413+

414+ f'' s a = f s a <> f' s a

415+

416+ f' s (DataBindingGroupDeclaration ds) =

417+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

418+ in foldMap (f'' s') ds

419+ f' s (ValueDeclaration name _ bs (Right val)) =

420+ let s' = S.insert name s

421+ in foldMap (h'' s') bs <> g'' s' val

422+ f' s (ValueDeclaration name _ bs (Left gs)) =

423+ let s' = S.insert name s

424+ s'' = S.union s' (S.fromList (concatMap binderNames bs))

425+ in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs

426+ f' s (BindingGroupDeclaration ds) =

427+ let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))

428+ in foldMap (\(_, _, val) -> g'' s' val) ds

429+ f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds

430+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds

431+ f' s (PositionedDeclaration _ _ d) = f'' s d

432+ f' _ _ = mempty

433+

434+ g'' s a = g s a <> g' s a

435+

436+ g' s (UnaryMinus v1) = g'' s v1

437+ g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

438+ g' s (Parens v1) = g'' s v1

439+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

440+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441+ g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442+ g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443+ g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)

444+ g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

445+ g' s (Accessor _ v1) = g'' s v1

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

447+ g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)

448+ g' s (Abs (Left name) v1) =

449+ let s' = S.insert name s

450+ in g'' s' v1

451+ g' s (Abs (Right b) v1) =

452+ let s' = S.union (S.fromList (binderNames b)) s

453+ in g'' s' v1

454+ g' s (App v1 v2) = g'' s v1 <> g'' s v2

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

456+ g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts

457+ g' s (TypedValue _ v1 _) = g'' s v1

458+ g' s (Let ds v1) =

459+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

460+ in foldMap (f'' s') ds <> g'' s' v1

461+ g' s (Do es) = fold . snd . mapAccumL j'' s $ es

462+ g' s (PositionedValue _ _ v1) = g'' s v1

463+ g' _ _ = mempty

464+

465+ h'' s a = h s a <> h' s a

466+

467+ h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

468+ h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

469+ h' s (ArrayBinder bs) = foldMap (h'' s) bs

470+ h' s (NamedBinder name b1) =

471+ let s' = S.insert name s

472+ in h'' s' b1

473+ h' s (PositionedBinder _ _ b1) = h'' s b1

474+ h' s (TypedBinder _ b1) = h'' s b1

475+ h' _ _ = mempty

476+

477+ i'' s a = i s a <> i' s a

478+

479+ i' s (CaseAlternative bs (Right val)) =

480+ let s' = S.union s (S.fromList (concatMap binderNames bs))

481+ in foldMap (h'' s) bs <> g'' s' val

482+ i' s (CaseAlternative bs (Left gs)) =

483+ let s' = S.union s (S.fromList (concatMap binderNames bs))

484+ in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

485+

486+ j'' s a = let (s', r) = j' s a in (s', j s a <> r)

487+

488+ j' s (DoNotationValue v) = (s, g'' s v)

489+ j' s (DoNotationBind b v) =

490+ let s' = S.union (S.fromList (binderNames b)) s

491+ in (s', h'' s b <> g'' s' v)

492+ j' s (DoNotationLet ds) =

493+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

494+ in (s', foldMap (f'' s') ds)

495+ j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

496+

497+ getDeclIdent :: Declaration -> Maybe Ident

498+ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d

499+ getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

500+ getDeclIdent (TypeDeclaration ident _) = Just ident

501+ getDeclIdent _ = Nothing

502+

392503accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

393504accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

394505 where

src/Language/PureScript/CodeGen/JS.hs+92−26

@@ -29,11 +29,13 @@ import Prelude ()

2929import Prelude.Compat

3030

3131import Data.List ((\\), delete, intersect)

32−import Data.Maybe (isNothing)

32+import Data.Maybe (isNothing, fromMaybe)

33+import qualified Data.Map as M

3334import qualified Data.Traversable as T (traverse)

3435

3536import Control.Arrow ((&&&))

3637import Control.Monad (replicateM, forM)

38+import Control.Monad.Error.Class (MonadError(..))

3739import Control.Monad.Reader (MonadReader, asks)

3840import Control.Monad.Supply.Class

3941

@@ -43,6 +45,7 @@ import Language.PureScript.CodeGen.JS.AST as AST

4345import Language.PureScript.CodeGen.JS.Common as Common

4446import Language.PureScript.CoreFn

4547import Language.PureScript.Names

48+import Language.PureScript.Errors

4649import Language.PureScript.CodeGen.JS.Optimizer

4750import Language.PureScript.Options

4851import Language.PureScript.Traversals (sndM)

@@ -54,33 +57,90 @@ import System.FilePath.Posix ((</>))

5457-- Generate code in the simplified Javascript intermediate representation for all declarations in a

5558-- module.

5659--

57−moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)

60+moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

5861 => Module Ann -> Maybe JS -> m [JS]

59−moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

60− jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps

61− jsDecls <- mapM bindToJs decls

62− optimized <- T.traverse (T.traverse optimize) jsDecls

63− comments <- not <$> asks optionsNoComments

64− let strict = JSStringLiteral "use strict"

65− let header = if comments && not (null coms) then JSComment coms strict else strict

66− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

67− let moduleBody = header : foreign' ++ jsImports ++ concat optimized

68− let foreignExps = exps `intersect` (fst `map` foreigns)

69− let standardExps = exps \\ foreignExps

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

71− ++ map (runIdent &&& foreignIdent) foreignExps

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

62+moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

63+ rethrow (addHint (ErrorInModule mn)) $ do

64+ let usedNames = concatMap getNames decls

65+ let mnLookup = renameImports usedNames imps

66+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps

67+ let decls' = renameModules mnLookup decls

68+ jsDecls <- mapM bindToJs decls'

69+ optimized <- T.traverse (T.traverse optimize) jsDecls

70+ comments <- not <$> asks optionsNoComments

71+ let strict = JSStringLiteral "use strict"

72+ let header = if comments && not (null coms) then JSComment coms strict else strict

73+ let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

74+ let moduleBody = header : foreign' ++ jsImports ++ concat optimized

75+ let foreignExps = exps `intersect` (fst `map` foreigns)

76+ let standardExps = exps \\ foreignExps

77+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps

78+ ++ map (runIdent &&& foreignIdent) foreignExps

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

7380

7481 where

7582

7683 -- |

77− -- Generates Javascript code for a module import.

84+ -- Extracts all declaration names from a binding group.

7885 --

79− importToJs :: ModuleName -> m JS

80− importToJs mn' = do

86+ getNames :: Bind Ann -> [Ident]

87+ getNames (NonRec ident _) = [ident]

88+ getNames (Rec vals) = map fst vals

89+

90+ -- |

91+ -- Creates alternative names for each module to ensure they don't collide

92+ -- with declaration names.

93+ --

94+ renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

95+ renameImports ids mns = go M.empty ids mns

96+ where

97+ go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

98+ go acc used (mn' : mns') =

99+ let mni = Ident $ runModuleName mn'

100+ in if mni `elem` used

101+ then let newName = freshModuleName 1 mn' used

102+ in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'

103+ else go (M.insert mn' mn' acc) (mni : used) mns'

104+ go acc _ [] = acc

105+

106+ freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

107+ freshModuleName i mn'@(ModuleName pns) used =

108+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]

109+ in if Ident (runModuleName newName) `elem` used

110+ then freshModuleName (i + 1) mn' used

111+ else newName

112+

113+ -- |

114+ -- Generates Javascript code for a module import, binding the required module

115+ -- to the alternative

116+ --

117+ importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS

118+ importToJs mnLookup mn' = do

81119 path <- asks optionsRequirePath

120+ let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

82121 let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]

83− return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)

122+ return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)

123+

124+ -- |

125+ -- Replaces the `ModuleName`s in the AST so that the generated code refers to

126+ -- the collision-avoiding renamed module imports.

127+ --

128+ renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]

129+ renameModules mnLookup binds =

130+ let (f, _, _) = everywhereOnValues id goExpr goBinder

131+ in map f binds

132+ where

133+ goExpr :: Expr a -> Expr a

134+ goExpr (Var ann q) = Var ann (renameQual q)

135+ goExpr e = e

136+ goBinder :: Binder a -> Binder a

137+ goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs

138+ goBinder b = b

139+ renameQual :: Qualified a -> Qualified a

140+ renameQual (Qualified (Just mn') a) =

141+ let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

142+ in Qualified (Just mnSafe) a

143+ renameQual q = q

84144

85145 -- |

86146 -- Generate code in the simplified Javascript intermediate representation for a declaration

@@ -129,8 +189,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

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

130190 --

131191 valueToJs :: Expr Ann -> m JS

132− valueToJs (Literal _ l) =

133− literalToValueJS l

192+ valueToJs (Literal (pos, _, _, _) l) =

193+ maybe id rethrowWithPosition pos $ literalToValueJS l

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

135195 return $ JSAccessor "value" $ qualifiedToJS id name

136196 valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =

@@ -207,7 +267,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

207267 iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

208268

209269 literalToValueJS :: Literal (Expr Ann) -> m JS

210− literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n

270+ literalToValueJS (NumericLiteral (Left i)) =

271+ let minInt = -2147483648

272+ maxInt = 2147483647

273+ in if i < minInt || i > maxInt

274+ then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt

275+ else return $ JSNumericLiteral (Left i)

276+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)

211277 literalToValueJS (StringLiteral s) = return $ JSStringLiteral s

212278 literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]

213279 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -275,10 +341,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

275341 go _ _ _ = internalError "Invalid arguments to bindersToJs"

276342

277343 failedPatternError :: [String] -> JS

278− failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]

344+ failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]

279345

280− errorMessage :: String

281− errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

346+ failedPatternMessage :: String

347+ failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

282348

283349 valueError :: String -> JS -> JS

284350 valueError _ l@(JSNumericLiteral _) = l

src/Language/PureScript/Errors.hs+173−57

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

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

2−--

3−-- Module : Language.PureScript.Error

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

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

14−

151{-# LANGUAGE GeneralizedNewtypeDeriving #-}

162{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RecordWildCards #-}

174{-# LANGUAGE MultiParamTypeClasses #-}

185

196module Language.PureScript.Errors where

@@ -24,7 +11,6 @@ import Prelude.Compat

2411import Data.Ord (comparing)

2512import Data.Either (lefts, rights)

2613import Data.List (intercalate, transpose, nub, nubBy, sortBy)

27−import Data.Function (on)

2814import Data.Foldable (fold)

2915

3016import qualified Data.Map as M

@@ -33,7 +19,7 @@ import Control.Monad

3319import Control.Monad.Writer

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

3521import Control.Monad.Trans.State.Lazy

36−import Control.Arrow (first, (&&&))

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

3723

3824import Language.PureScript.Crash

3925import Language.PureScript.AST

@@ -143,6 +129,15 @@ data SimpleErrorMessage

143129 | UnusedDctorImport ProperName

144130 | UnusedDctorExplicitImport ProperName [ProperName]

145131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132+ | DeprecatedClassImport ModuleName ProperName

133+ | DeprecatedClassExport ProperName

134+ | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135+ | DuplicateSelectiveImport ModuleName

136+ | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

137+ | DuplicateImportRef String

138+ | DuplicateExportRef String

139+ | IntOutOfRange Integer String Integer Integer

140+ | RedundantEmptyHidingImport ModuleName

146141 deriving (Show)

147142

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

@@ -278,6 +273,15 @@ errorCode em = case unwrapErrorMessage em of

278273 UnusedDctorImport{} -> "UnusedDctorImport"

279274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

280275 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

276+ DeprecatedClassImport{} -> "DeprecatedClassImport"

277+ DeprecatedClassExport{} -> "DeprecatedClassExport"

278+ RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

279+ DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

280+ DuplicateImport{} -> "DuplicateImport"

281+ DuplicateImportRef{} -> "DuplicateImportRef"

282+ DuplicateExportRef{} -> "DuplicateExportRef"

283+ IntOutOfRange{} -> "IntOutOfRange"

284+ RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

281285

282286

283287-- |

@@ -311,11 +315,16 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors

311315addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

312316addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se

313317

314−-- | The various types of things which might need to be relabelled in errors messages.

315−data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)

316−

317318-- | A map from rigid type variable name/unknown variable pairs to new variables.

318−type UnknownMap = M.Map (LabelType, Int) Int

319+data TypeMap = TypeMap

320+ { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)

321+ , umNextSkolem :: Int

322+ , umUnknownMap :: M.Map Int Int

323+ , umNextUnknown :: Int

324+ } deriving Show

325+

326+defaultUnknownMap :: TypeMap

327+defaultUnknownMap = TypeMap M.empty 0 M.empty 0

319328

320329-- | How critical the issue is

321330data Level = Error | Warning deriving Show

@@ -326,48 +335,72 @@ data Level = Error | Warning deriving Show

326335unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

327336unwrapErrorMessage (ErrorMessage _ se) = se

328337

329−replaceUnknowns :: Type -> State UnknownMap Type

338+replaceUnknowns :: Type -> State TypeMap Type

330339replaceUnknowns = everywhereOnTypesM replaceTypes

331340 where

332− lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap)

333− lookupTable x m = case M.lookup x m of

334− Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)

335− Just i -> (i, m)

336−

337− replaceTypes :: Type -> State UnknownMap Type

338− replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)

339− replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)

341+ replaceTypes :: Type -> State TypeMap Type

342+ replaceTypes (TUnknown u) = do

343+ m <- get

344+ case M.lookup u (umUnknownMap m) of

345+ Nothing -> do

346+ let u' = umNextUnknown m

347+ put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }

348+ return (TUnknown u')

349+ Just u' -> return (TUnknown u')

350+ replaceTypes (Skolem name s sko ss) = do

351+ m <- get

352+ case M.lookup s (umSkolemMap m) of

353+ Nothing -> do

354+ let s' = umNextSkolem m

355+ put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }

356+ return (Skolem name s' sko ss)

357+ Just (_, s', _) -> return (Skolem name s' sko ss)

340358 replaceTypes other = return other

341359

342360onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

343361onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple

344362 where

345− gSimple (InfiniteType t) = InfiniteType <$> f t

346− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

347− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

348− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

349− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

350− gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

351− gSimple other = pure other

352− gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2

353− gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2

354− gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t

355− gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t

356− gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2

357− gHint other = pure other

363+ gSimple (InfiniteType t) = InfiniteType <$> f t

364+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

365+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

366+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

367+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

368+ gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

369+ gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts

370+ gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

371+ gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

372+ gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

373+ gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

374+ gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

375+ gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

376+ gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

377+

378+ gSimple other = pure other

379+

380+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2

381+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2

382+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t

383+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t

384+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2

385+ gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

386+ gHint other = pure other

358387

359388-- |

360389-- Pretty print a single error, simplifying if necessary

361390--

362−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

363−prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

391+prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box

392+prettyPrintSingleError full level e = do

393+ em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

394+ um <- get

395+ return (prettyPrintErrorMessage um em)

364396 where

365397

366398 -- Pretty print an ErrorMessage

367− prettyPrintErrorMessage :: ErrorMessage -> Box.Box

368− prettyPrintErrorMessage (ErrorMessage hints simple) =

369− paras $

399+ prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

400+ prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

401+ paras

370402 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

403+ , Box.moveDown 1 typeInformation

371404 , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "

372405 , line $ "or to contribute content related to this " ++ levelText ++ "."

373406 ]

@@ -376,6 +409,23 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

376409 wikiUri :: String

377410 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

378411

412+ typeInformation :: Box.Box

413+ typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types]

414+ | otherwise = Box.emptyBox 0 0

415+ where

416+ types :: [Box.Box]

417+ types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++

418+ map unknownInfo (M.elems (umUnknownMap typeMap))

419+

420+ skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box

421+ skolemInfo (name, s, ss) =

422+ paras $

423+ line (name ++ show s ++ " is a rigid type variable")

424+ : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss

425+

426+ unknownInfo :: Int -> Box.Box

427+ unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"

428+

379429 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

380430 renderSimpleErrorMessage (CannotGetFileInfo path) =

381431 paras [ line "Unable to read file info: "

@@ -576,7 +626,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

576626 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

577627 , Box.vcat Box.left (map typeAtomAsBox ts)

578628 ]

629+ , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."

630+ | any containsUnknowns ts

631+ ]

579632 ]

633+ where

634+ containsUnknowns :: Type -> Bool

635+ containsUnknowns = everythingOnTypes (||) go

636+ where

637+ go TUnknown{} = True

638+ go _ = False

580639 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

581640 paras [ line "Type class instance for"

582641 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

@@ -715,8 +774,50 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

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

716775

717776 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

718− paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax."

719− , line $ "This syntax form will be removed in PureScript 0.9." ]

777+ paras [ line $ "Import uses the deprecated 'qualified' syntax:"

778+ , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

779+ , line "Should instead use the form:"

780+ , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

781+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

782+ ]

783+

784+ renderSimpleErrorMessage (DeprecatedClassImport mn name) =

785+ paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:"

786+ , indent $ line $ runProperName name

787+ , line "Should instead use the form:"

788+ , indent $ line $ "class " ++ runProperName name

789+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

790+ ]

791+

792+ renderSimpleErrorMessage (DeprecatedClassExport name) =

793+ paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"

794+ , indent $ line $ runProperName name

795+ , line "Should instead use the form:"

796+ , indent $ line $ "class " ++ runProperName name

797+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

798+ ]

799+

800+ renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

801+ line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import"

802+

803+ renderSimpleErrorMessage (DuplicateSelectiveImport name) =

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

805+

806+ renderSimpleErrorMessage (DuplicateImport name imp qual) =

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

808+

809+ renderSimpleErrorMessage (DuplicateImportRef ref) =

810+ line $ "Import list contains multiple references to " ++ ref

811+

812+ renderSimpleErrorMessage (DuplicateExportRef ref) =

813+ line $ "Export list contains multiple references to " ++ ref

814+

815+ renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

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

817+ , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]

818+

819+ renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

820+ line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

720821

721822 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

722823 renderHint (ErrorUnifyingTypes t1 t2) detail =

@@ -849,11 +950,25 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

849950 -- Pretty print and export declaration

850951 prettyPrintExport :: DeclarationRef -> String

851952 prettyPrintExport (TypeRef pn _) = runProperName pn

852− prettyPrintExport (ValueRef ident) = showIdent ident

853− prettyPrintExport (TypeClassRef pn) = runProperName pn

854− prettyPrintExport (TypeInstanceRef ident) = showIdent ident

855− prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

856− prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

953+ prettyPrintExport ref = prettyPrintRef ref

954+

955+ prettyPrintRef :: DeclarationRef -> String

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

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

958+ prettyPrintRef (ValueRef ident) = showIdent ident

959+ prettyPrintRef (TypeClassRef pn) = runProperName pn

960+ prettyPrintRef (ProperRef pn) = runProperName pn

961+ prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

963+ prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

964+

965+ prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

966+ prettyPrintImport mn idt qual =

967+ let i = case idt of

968+ Implicit -> runModuleName mn

969+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

970+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

971+ in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

857972

858973 -- | Simplify an error message

859974 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

@@ -878,6 +993,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

878993 hintCategory ErrorUnifyingTypes{} = CheckHint

879994 hintCategory ErrorInSubsumption{} = CheckHint

880995 hintCategory ErrorInApplication{} = CheckHint

996+ hintCategory ErrorCheckingKind{} = CheckHint

881997 hintCategory PositionedError{} = PositionHint

882998 hintCategory _ = OtherHint

883999

@@ -895,13 +1011,13 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu

8951011

8961012-- | Pretty print warnings as a Box

8971013prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

898−prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1014+prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

8991015

9001016-- | Pretty print errors as a Box

9011017prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

902−prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1018+prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

9031019

904−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box

1020+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box

9051021prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

9061022 result <- prettyPrintSingleError full level e

9071023 return $

src/Language/PureScript/Linter.hs+39−35

@@ -14,13 +14,14 @@

1414

1515{-# LANGUAGE FlexibleContexts #-}

1616{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

1718

1819module Language.PureScript.Linter (lint, module L) where

1920

2021import Prelude ()

2122import Prelude.Compat

2223

23−import Data.List (mapAccumL, nub, (\\))

24+import Data.List (nub, (\\))

2425import Data.Maybe (mapMaybe)

2526import Data.Monoid

2627

@@ -54,43 +55,46 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

5455 getDeclIdent _ = Nothing

5556

5657 lintDeclaration :: Declaration -> m ()

57− lintDeclaration d =

58− let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def

59−

60− f' :: Declaration -> MultipleErrors

61− f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)

62− f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)

63− f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

64− f' dec = f dec <> checkTypeVarsInDecl dec

65−

66− in tell (f' d)

58+ lintDeclaration = tell . f

6759 where

68− def s _ = (s, mempty)

60+ (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo

61+

62+ f :: Declaration -> MultipleErrors

63+ f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

64+ f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)

65+ f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

66+ f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

6967

70− stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)

71− stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)

68+ stepD :: S.Set Ident -> Declaration -> MultipleErrors

69+ stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls

70+ where

71+ go :: Declaration -> MultipleErrors

72+ go (PositionedDeclaration _ _ d') = go d'

73+ go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op)

74+ go _ = mempty

75+ stepD _ _ = mempty

76+

77+ stepE :: S.Set Ident -> Expr -> MultipleErrors

78+ stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

79+ stepE s (Let ds' _) = foldMap go ds'

80+ where

81+ go d | Just i <- getDeclIdent d

82+ , i `S.member` s = errorMessage (ShadowedName i)

83+ | otherwise = mempty

84+ stepE _ _ = mempty

85+

86+ stepB :: S.Set Ident -> Binder -> MultipleErrors

87+ stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)

88+ stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)

89+ stepB _ _ = mempty

90+

91+ stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors

92+ stepDo s (DoNotationLet ds') = foldMap go ds'

7293 where

73− go :: Declaration -> MultipleErrors -> MultipleErrors

74− go (PositionedDeclaration _ _ d') errs = go d' errs

75− go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs

76− go _ errs = errs

77− stepD s _ = (s, mempty)

78−

79− stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)

80− stepE s (Abs (Left name) _) = bindName s name

81− stepE s (Let ds' _) =

82− case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of

83− (s', es) -> (s', mconcat es)

84− stepE s _ = (s, mempty)

85−

86− stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)

87− stepB s (VarBinder name) = bindName s name

88− stepB s (NamedBinder name _) = bindName s name

89− stepB s (TypedBinder _ b) = stepB s b

90− stepB s _ = (s, mempty)

91−

92− bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

93− bindName = bind ShadowedName

94+ go d | Just i <- getDeclIdent d

95+ , i `S.member` s = errorMessage (ShadowedName i)

96+ | otherwise = mempty

97+ stepDo _ _ = mempty

9498

9599 checkTypeVarsInDecl :: Declaration -> MultipleErrors

96100 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

src/Language/PureScript/Linter/Imports.hs+16−8

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

99import qualified Data.Map as M

1010import Data.Maybe (mapMaybe)

11−import Data.List ((\\), find, intersect)

11+import Data.List ((\\), find, intersect, nub)

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

1313import Control.Monad.Writer.Class

14−import Control.Monad(unless,when)

14+import Control.Monad (unless,when)

1515import Data.Foldable (forM_)

1616

1717import Language.PureScript.AST.Declarations

@@ -25,7 +25,11 @@ import Language.PureScript.Sugar.Names.Imports

2525import qualified Language.PureScript.Constants as C

2626

2727-- | Imported name used in some type or expression.

28−data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName)

28+data Name

29+ = IdentName (Qualified Ident)

30+ | TypeName (Qualified ProperName)

31+ | DctorName (Qualified ProperName)

32+ | ClassName (Qualified ProperName)

2933

3034-- | Map of module name to list of imported names from that module which have been used.

3135type UsedImports = M.Map ModuleName [Name]

@@ -46,7 +50,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

4650 in case declType of

4751 Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni

4852 Explicit declrefs -> do

49− let idents = mapMaybe runDeclRef declrefs

53+ let idents = nub (mapMaybe runDeclRef declrefs)

5054 let diff = idents \\ usedNames

5155 case (length diff, length idents) of

5256 (0, _) -> return ()

@@ -63,6 +67,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

6367 let ddiff = ctors \\ usedDctors

6468 in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

6569 _ -> return ()

70+

6671 return ()

6772

6873 _ -> return ()

@@ -73,10 +78,11 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

7378

7479 -- rely on exports being elaborated by this point

7580 alwaysUsedModules :: [ ModuleName ]

76− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports

81+ alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

7782 where

78− isExport (ModuleRef mn) = Just mn

79− isExport _ = Nothing

83+ extractModule (PositionedDeclarationRef _ _ r) = extractModule r

84+ extractModule (ModuleRef mn) = Just mn

85+ extractModule _ = Nothing

8086

8187 qnameUsed :: Maybe ModuleName -> Bool

8288 qnameUsed (Just qn) = qn `elem` alwaysUsedModules

@@ -102,7 +108,8 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

102108

103109matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

104110matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

105−matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x

111+matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x

112+matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x

106113matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

107114matchName _ _ _ = Nothing

108115

@@ -114,6 +121,7 @@ runDeclRef :: DeclarationRef -> Maybe String

114121runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

115122runDeclRef (ValueRef ident) = Just $ showIdent ident

116123runDeclRef (TypeRef pn _) = Just $ runProperName pn

124+runDeclRef (TypeClassRef pn) = Just $ runProperName pn

117125runDeclRef _ = Nothing

118126

119127getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])

src/Language/PureScript/Parser/Declarations.hs+11−25

@@ -1,22 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.Parser.Declarations

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Parsers for module definitions and declarations

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE FlexibleContexts #-}

172{-# LANGUAGE ScopedTypeVariables #-}

183{-# LANGUAGE TupleSections #-}

194

5+-- |

6+-- Parsers for module definitions and declarations

7+--

208module Language.PureScript.Parser.Declarations (

219 parseDeclaration,

2210 parseModule,

@@ -170,18 +158,16 @@ parseImportDeclaration' = do

170158

171159parseDeclarationRef :: TokenParser DeclarationRef

172160parseDeclarationRef =

173− parseModuleRef <|>

174161 withSourceSpan PositionedDeclarationRef

175− (ValueRef <$> parseIdent

176− <|> do name <- properName

177− dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

178− return $ maybe (TypeClassRef name) (TypeRef name) dctors

179− )

162+ $ (ValueRef <$> parseIdent)

163+ <|> parseProperRef

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

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

180166 where

181− parseModuleRef :: TokenParser DeclarationRef

182− parseModuleRef = do

183− name <- indented *> reserved "module" *> moduleName

184− return $ ModuleRef name

167+ parseProperRef = do

168+ name <- properName

169+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

170+ return $ maybe (ProperRef name) (TypeRef name) dctors

185171

186172parseTypeClassDeclaration :: TokenParser Declaration

187173parseTypeClassDeclaration = do

src/Language/PureScript/Pretty/Types.hs+1−1

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

4545 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

4646 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

4747 match (TUnknown u) = Just $ text $ '_' : show u

48− match (Skolem name s _) = Just $ text $ name ++ show s

48+ match (Skolem name s _ _) = Just $ text $ name ++ show s

4949 match REmpty = Just $ text "()"

5050 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

5151 match _ = Nothing

src/Language/PureScript/Sugar/BindingGroups.hs+12−11

@@ -102,20 +102,21 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

102102collapseBindingGroupsForValue other = other

103103

104104usedIdents :: ModuleName -> Declaration -> [Ident]

105−usedIdents moduleName =

106− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def

107− in nub . f

105+usedIdents moduleName = nub . usedIdents' S.empty . getValue

108106 where

109− def s _ = (s, [])

107+ def _ _ = []

110108

111− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])

112− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])

113− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])

114− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])

115− usedNamesE scope _ = (scope, [])

109+ getValue (ValueDeclaration _ _ [] (Right val)) = val

110+ getValue ValueDeclaration{} = internalError "Binders should have been desugared"

111+ getValue (PositionedDeclaration _ _ d) = getValue d

112+ getValue _ = internalError "Expected ValueDeclaration"

113+

114+ (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

116115

117− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])

118− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])

116+ usedNamesE :: S.Set Ident -> Expr -> [Ident]

117+ usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]

118+ usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]

119+ usedNamesE _ _ = []

119120

120121usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

121122usedImmediateIdents moduleName =

src/Language/PureScript/Sugar/Names.hs+43−49

@@ -1,16 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.Sugar.Names

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

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152{-# LANGUAGE RecordWildCards #-}

163{-# LANGUAGE ScopedTypeVariables #-}

@@ -49,8 +36,9 @@ import Language.PureScript.Linter.Imports

4936desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

5037desugarImports externs modules = do

5138 env <- silence $ foldM externsEnv primEnv externs

52− env' <- foldM updateEnv env modules

53− traverse (renameInModule' env') modules

39+ modules' <- traverse updateExportRefs modules

40+ (modules'', env') <- foldM updateEnv ([], env) modules'

41+ traverse (renameInModule' env') modules''

5442 where

5543 silence :: m a -> m a

5644 silence = censor (const mempty)

@@ -90,16 +78,16 @@ desugarImports externs modules = do

9078 toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

9179 toExportedValue _ = Nothing

9280

93− updateEnv :: Env -> Module -> m Env

94− updateEnv env m@(Module ss _ mn _ refs) =

81+ updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

82+ updateEnv (ms, env) m@(Module ss _ mn _ refs) =

9583 case mn `M.lookup` env of

9684 Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]

9785 Nothing -> do

9886 members <- findExportable m

9987 let env' = M.insert mn (ss, nullImports, members) env

100− imps <- resolveImports env' m

88+ (m', imps) <- resolveImports env' m

10189 exps <- maybe (return members) (resolveExports env' mn imps members) refs

102− return $ M.insert mn (ss, imps, exps) env

90+ return (m' : ms, M.insert mn (ss, imps, exps) env)

10391

10492 renameInModule' :: Env -> Module -> m Module

10593 renameInModule' env m@(Module _ _ mn _ _) =

@@ -107,7 +95,7 @@ desugarImports externs modules = do

10795 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

10896 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)

10997 findUnusedImports m env used

110− return $ elaborateImports imps m'

98+ return m'

11199

112100-- |

113101-- Make all exports for a module explicit. This may still effect modules that

@@ -127,23 +115,6 @@ elaborateExports exps (Module ss coms mn decls refs) =

127115 my :: (Exports -> [(a, ModuleName)]) -> [a]

128116 my f = fst `map` filter ((== mn) . snd) (f exps)

129117

130−-- |

131−-- Add `import X ()` for any modules where there are only fully qualified references to members.

132−-- This ensures transitive instances are included when using a member from a module.

133−--

134−elaborateImports :: Imports -> Module -> Module

135−elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' exps

136− where

137− decls' :: [Declaration]

138− decls' =

139− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])

140− in mkImport `map` nub (f `concatMap` decls) ++ decls

141− fqValues :: Expr -> [ModuleName]

142− fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn']

143− fqValues _ = []

144− mkImport :: ModuleName -> Declaration

145− mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing False

146−

147118-- |

148119-- Replaces all local names with qualified names within a module and checks that all existing

149120-- qualified names are valid.

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

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

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

173144 updateDecl s d = return (s, d)

174− --

145+

175146 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

176147 updateValue (_, bound) v@(PositionedValue pos' _ _) =

177148 return ((Just pos', bound), v)

@@ -192,7 +163,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

192163 updateValue s@(pos, _) (TypedValue check val ty) =

193164 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

194165 updateValue s v = return (s, v)

195− --

166+

196167 updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

197168 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

198169 return ((Just pos, bound), v)

@@ -204,7 +175,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

204175 return (s', TypedBinder t' b')

205176 updateBinder s v =

206177 return (s, v)

207− --

178+

208179 updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

209180 updateCase (pos, bound) c@(CaseAlternative bs _) =

210181 return ((pos, concatMap binderNames bs ++ bound), c)

@@ -226,13 +197,13 @@ renameInModule env imports (Module ss coms mn decls exps) =

226197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

227198

228199 updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

229− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName

200+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName

230201

231202 updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

232203 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName

233204

234205 updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

235− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName

206+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName

236207

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

238209 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName

@@ -279,19 +250,42 @@ renameInModule env imports (Module ss coms mn decls exps) =

279250 -- by qualified importing). If that's not the case, then we just need to

280251 -- check it refers to a symbol in another module.

281252 (Nothing, Just mn'') -> do

282− when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

283− modExports <- getExports mn''

253+ modExports <- getExports env mn''

284254 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

285255 -- If neither of the above cases are true then it's an undefined or

286256 -- unimported symbol.

287257 _ -> throwError . errorMessage $ unknown qname

288258 where

289− isExplicitQualModule :: ModuleName -> Bool

290− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)

291259 positioned err = case pos of

292260 Nothing -> err

293261 Just pos' -> rethrowWithPosition pos' err

294262

295− -- Gets the exports for a module, or an error message if the module doesn't exist

296− getExports :: ModuleName -> m Exports

297− getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env

263+-- |

264+-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

265+-- depending on what is availble within the module. Warns when a `ProperRef`

266+-- desugars into a `TypeClassRef`.

267+--

268+updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module

269+updateExportRefs (Module ss coms mn decls exps) =

270+ Module ss coms mn decls <$> traverse (traverse updateRef) exps

271+ where

272+

273+ updateRef :: DeclarationRef -> m DeclarationRef

274+ updateRef (ProperRef name)

275+ | name `elem` classNames = do

276+ tell . errorMessage $ DeprecatedClassExport name

277+ return $ TypeClassRef name

278+ -- Fall through case here - assume it's a type if it's not a class.

279+ -- If it's a reference to something that doesn't actually exist it will

280+ -- be picked up elsewhere

281+ | otherwise = return $ TypeRef name (Just [])

282+ updateRef (PositionedDeclarationRef pos com ref) =

283+ warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

284+ updateRef other = return other

285+

286+ classNames :: [ProperName]

287+ classNames = mapMaybe go decls

288+ where

289+ go (PositionedDeclaration _ _ d) = go d

290+ go (TypeClassDeclaration name _ _ _) = Just name

291+ go _ = Nothing

src/Language/PureScript/Sugar/Names/Env.hs+5−13

@@ -1,16 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.Sugar.Names.Env

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

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152

163module Language.PureScript.Sugar.Names.Env

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

2613 , exportType

2714 , exportTypeClass

2815 , exportValue

16+ , getExports

2917 ) where

3018

3119import qualified Data.Map as M

@@ -189,3 +177,7 @@ addExport what name mn exports =

189177--

190178throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b

191179throwConflictError conflict = throwError . errorMessage . conflict

180+

181+-- Gets the exports for a module, or an error message if the module doesn't exist

182+getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

183+getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

src/Language/PureScript/Sugar/Names/Exports.hs+20−1

@@ -15,6 +15,7 @@

1515{-# LANGUAGE RankNTypes #-}

1616{-# LANGUAGE ScopedTypeVariables #-}

1717{-# LANGUAGE TupleSections #-}

18+{-# LANGUAGE LambdaCase #-}

1819

1920module Language.PureScript.Sugar.Names.Exports

2021 ( findExportable

@@ -29,6 +30,7 @@ import Data.Maybe (fromMaybe, mapMaybe)

2930import Data.Foldable (traverse_)

3031

3132import Control.Monad

33+import Control.Monad.Writer.Class (MonadWriter(..))

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

3335

3436import qualified Data.Map as M

@@ -66,14 +68,31 @@ findExportable (Module _ _ mn ds _) =

6668-- Resolves the exports for a module, filtering out members that have not been

6769-- exported and elaborating re-exports of other modules.

6870--

69−resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

71+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

7072resolveExports env mn imps exps refs =

7173 rethrow (addHint (ErrorInModule mn)) $ do

7274 filtered <- filterModule mn exps refs

75+ let (dupeRefs, dupeDctors) = findDuplicateRefs refs

76+ warnDupeRefs dupeRefs

77+ warnDupeDctors dupeDctors

7378 foldM elaborateModuleExports filtered refs

7479

7580 where

7681

82+ warnDupeRefs :: [DeclarationRef] -> m ()

83+ warnDupeRefs = traverse_ $ \case

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

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

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

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

88+ _ -> return ()

89+

90+ warnDupeDctors :: [ProperName] -> m ()

91+ warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)

92+

93+ warnDupe :: String -> m ()

94+ warnDupe ref = tell . errorMessage $ DuplicateExportRef ref

95+

7796 -- Takes the current module's imports, the accumulated list of exports, and a

7897 -- `DeclarationRef` for an explicit export. When the ref refers to another

7998 -- module, export anything from the imports that matches for that module.

src/Language/PureScript/Sugar/Names/Imports.hs+155−52

@@ -1,19 +1,7 @@

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

2−--

3−-- Module : Language.PureScript.Sugar.Names.Imports

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

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152{-# LANGUAGE ScopedTypeVariables #-}

163{-# LANGUAGE TupleSections #-}

4+{-# LANGUAGE LambdaCase #-}

175

186module Language.PureScript.Sugar.Names.Imports

197 ( resolveImports

@@ -24,14 +12,15 @@ module Language.PureScript.Sugar.Names.Imports

2412import Prelude ()

2513import Prelude.Compat

2614

27−import Data.List (find)

28−import Data.Maybe (fromMaybe, isNothing, fromJust)

29−import Data.Foldable (traverse_)

15+import Data.List (find, delete, (\\))

16+import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)

17+import Data.Foldable (traverse_, for_)

18+import Data.Traversable (for)

3019

3120import Control.Arrow (first)

3221import Control.Monad

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

34−import Control.Monad.Writer (MonadWriter(..), censor)

23+import Control.Monad.Writer (MonadWriter(..))

3524

3625import qualified Data.Map as M

3726

@@ -45,40 +34,136 @@ import Language.PureScript.Sugar.Names.Env

4534-- Finds the imports within a module, mapping the imported module name to an optional set of

4635-- explicitly imported declarations.

4736--

48−findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

37+findImports

38+ :: forall m

39+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40+ => [Declaration]

41+ -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

4942findImports = foldM (go Nothing) M.empty

5043 where

5144 go pos result (ImportDeclaration mn typ qual isOldSyntax) = do

5245 when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual)

53− checkImportRefType typ

5446 let imp = (pos, typ, qual)

5547 return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

56− go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d

48+ go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d

5749 go _ result _ = return result

5850

59− -- Ensure that classes don't appear in an `import X hiding (...)`

60− checkImportRefType :: ImportDeclarationType -> m ()

61− checkImportRefType (Hiding refs) = traverse_ checkImportRef refs

62− checkImportRefType _ = return ()

63− checkImportRef :: DeclarationRef -> m ()

64− checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name

65− checkImportRef _ = return ()

51+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

6652

6753-- |

6854-- Constructs a set of imports for a module.

6955--

70−resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

71−resolveImports env (Module _ _ currentModule decls _) =

72− censor (addHint (ErrorInModule currentModule)) $ do

73− scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls

74− foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

56+resolveImports

57+ :: forall m

58+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59+ => Env

60+ -> Module

61+ -> m (Module, Imports)

62+resolveImports env (Module ss coms currentModule decls exps) =

63+ warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

64+

65+ decls' <- traverse updateImportRef decls

66+ imports <- findImports decls'

67+

68+ for_ (M.toList imports) $ \(mn, imps) -> do

69+

70+ -- Better ordering for the warnings: the list is in last-import-first

71+ -- order, but we want the first appearence of an import to be the primary,

72+ -- and warnings to appear for later imports

73+ let imps' = reverse imps

74+

75+ warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps')

76+

77+ let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned)

78+

79+ warned' <- (warned ++) <$>

80+ if (length unqual < 2)

81+ then return []

82+ else case find (\(_, typ, _) -> typ == Implicit) unqual of

83+ Just i ->

84+ for (delete i unqual) $ \i'@(pos, typ, _) -> do

85+ warn pos $ RedundantUnqualifiedImport mn typ

86+ return i'

87+ Nothing ->

88+ for (tail unqual) $ \i@(pos, _, _) -> do

89+ warn pos $ DuplicateSelectiveImport mn

90+ return i

91+

92+ for_ (imps' \\ warned') $ \(pos, typ, _) ->

93+ let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of

94+ Explicit refs -> refs

95+ Hiding refs -> refs

96+ _ -> []

97+ in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors

98+

99+ return ()

100+

101+ let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports

102+ resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

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

104+

105+ where

106+ selfCartesianSubset :: [a] -> [(a, a)]

107+ selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs

108+ selfCartesianSubset [] = []

109+

110+ checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]

111+ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

112+ if (t1 == t2 && q1 == q2)

113+ then do

114+ warn pos $ DuplicateImport mn t2 q2

115+ return $ (pos, t2, q2) : xs

116+ else return xs

117+

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

119+ warnDupeRefs pos = traverse_ $ \case

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

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

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

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

124+ _ -> return ()

125+

126+ warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()

127+ warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

128+

129+ warnDupe :: Maybe SourceSpan -> String -> m ()

130+ warnDupe pos ref = warn pos $ DuplicateImportRef ref

131+

132+ warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()

133+ warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg

134+

135+ updateImportRef :: Declaration -> m Declaration

136+ updateImportRef (PositionedDeclaration pos com d) =

137+ warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138+ updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139+ modExports <- getExports env mn

140+ typ' <- case typ of

141+ Implicit -> return Implicit

142+ Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs

143+ Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs

144+ return $ ImportDeclaration mn typ' qual isOldSyntax

145+ updateImportRef other = return other

146+

147+ updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148+ updateProperRef importModule modExports (ProperRef name) =

149+ if name `elem` (fst `map` exportedTypeClasses modExports)

150+ then do

151+ tell . errorMessage $ DeprecatedClassImport importModule name

152+ return $ TypeClassRef name

153+ else return $ TypeRef name (Just [])

154+ updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155+ PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156+ updateProperRef _ _ other = return other

75157

76158-- | Constructs a set of imports for a single module import.

77−resolveModuleImport ::

78− forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

79− ModuleName -> Env -> Imports ->

80− (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->

81− m Imports

159+resolveModuleImport

160+ :: forall m

161+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162+ => ModuleName

163+ -> Env

164+ -> Imports

165+ -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

166+ -> m Imports

82167resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

83168 where

84169 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

@@ -94,19 +179,35 @@ resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

94179-- |

95180-- Extends the local environment for a module by resolving an import of another module.

96181--

97−resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports

98−resolveImport currentModule importModule exps imps impQual =

99− resolveByType

182+resolveImport

183+ :: forall m

184+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185+ => ModuleName

186+ -> ModuleName

187+ -> Exports

188+ -> Imports

189+ -> Maybe ModuleName

190+ -> ImportDeclarationType

191+ -> m Imports

192+resolveImport currentModule importModule exps imps impQual = resolveByType

100193 where

101194

102195 resolveByType :: ImportDeclarationType -> m Imports

103196 resolveByType Implicit = importAll importExplicit

104− resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports

105− resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)

197+ resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs

198+ resolveByType (Hiding refs) = do

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

200+ let isEmptyImport

201+ = M.null (importedTypes imps')

202+ && M.null (importedDataConstructors imps')

203+ && M.null (importedTypeClasses imps')

204+ && M.null (importedValues imps')

205+ when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule

206+ return imps'

106207

107208 -- Check that a 'DeclarationRef' refers to an importable symbol

108− checkRefs :: [DeclarationRef] -> m ()

109− checkRefs = traverse_ check

209+ checkRefs :: Bool -> [DeclarationRef] -> m ()

210+ checkRefs isHiding = traverse_ check

110211 where

111212 check (PositionedDeclarationRef pos _ r) =

112213 rethrowWithPosition pos $ check r

@@ -118,9 +219,9 @@ resolveImport currentModule importModule exps imps impQual =

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

119220 check (TypeClassRef name) =

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

121− --check (ModuleRef name) =

122− -- checkImportExists (const UnknownModule) (exportedModules exps) name

123− check _ = internalError "Invalid argument to checkRefs"

222+ check (ModuleRef name) | isHiding =

223+ throwError . errorMessage $ ImportHidingModule name

224+ check r = internalError $ "Invalid argument to checkRefs: " ++ show r

124225

125226 -- Check that an explicitly imported item exists in the module it is being imported from

126227 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

@@ -186,11 +287,13 @@ resolveImport currentModule importModule exps imps impQual =

186287 Just ((_, dctors), mn) -> map (, mn) dctors

187288

188289 -- Add something to the Imports if it does not already exist there

189− updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName)

190− -> (a -> String)

191− -> [(a, ModuleName)]

192− -> a

193− -> m (M.Map (Qualified a) (Qualified a, ModuleName))

290+ updateImports

291+ :: (Ord a)

292+ => M.Map (Qualified a) (Qualified a, ModuleName)

293+ -> (a -> String)

294+ -> [(a, ModuleName)]

295+ -> a

296+ -> m (M.Map (Qualified a) (Qualified a, ModuleName))

194297 updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of

195298

196299 -- If the name is not already present add it to the list, after looking up

src/Language/PureScript/TypeChecker/Entailment.hs+7−7

@@ -147,7 +147,7 @@ entails moduleName context = solve

147147-- and return a substitution from type variables to types which makes the type heads unify.

148148--

149149typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]

150−typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []

150+typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []

151151typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]

152152typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

153153typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2

@@ -164,12 +164,12 @@ typeHeadsAreEqual m r1@RCons{} r2@RCons{} =

164164 <*> go sd1 r1' sd2 r2'

165165 where

166166 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]

167− go [] REmpty [] REmpty = Just []

168− go [] (TUnknown _) _ _ = Just []

169− go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []

170− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []

171− go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]

172− go _ _ _ _ = Nothing

167+ go [] REmpty [] REmpty = Just []

168+ go [] (TUnknown _) _ _ = Just []

169+ go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []

170+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just []

171+ go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]

172+ go _ _ _ _ = Nothing

173173typeHeadsAreEqual _ _ _ = Nothing

174174

175175-- |

src/Language/PureScript/TypeChecker/Kinds.hs+1−1

@@ -226,7 +226,7 @@ infer' other = (, []) <$> go other

226226 go (TypeVar v) = do

227227 Just moduleName <- checkCurrentModule <$> get

228228 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

229− go (Skolem v _ _) = do

229+ go (Skolem v _ _ _) = do

230230 Just moduleName <- checkCurrentModule <$> get

231231 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

232232 go (TypeConstructor v) = do

src/Language/PureScript/TypeChecker/Skolems.hs+8−8

@@ -71,30 +71,30 @@ newSkolemScope = do

7171-- |

7272-- Skolemize a type variable by replacing its instances with fresh skolem constants

7373--

74−skolemize :: String -> Int -> SkolemScope -> Type -> Type

75−skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)

74+skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type

75+skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

7676

7777-- |

7878-- This function has one purpose - to skolemize type variables appearing in a

7979-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the

8080-- only example of scoped type variables.

8181--

82−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr

83−skolemizeTypesInValue ident sko scope =

82+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

83+skolemizeTypesInValue ident sko scope ss =

8484 let

8585 (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS

8686 in runIdentity . f

8787 where

8888 onExpr :: [String] -> Expr -> Identity ([String], Expr)

8989 onExpr sco (SuperClassDictionary c ts)

90− | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts))

90+ | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))

9191 onExpr sco (TypedValue check val ty)

92− | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty))

92+ | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))

9393 onExpr sco other = return (sco, other)

9494

9595 onBinder :: [String] -> Binder -> Identity ([String], Binder)

9696 onBinder sco (TypedBinder ty b)

97− | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b)

97+ | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)

9898 onBinder sco other = return (sco, other)

9999

100100 peelTypeVars :: Type -> [String]

@@ -129,7 +129,7 @@ skolemEscapeCheck root@TypedValue{} =

129129 collectSkolems :: Type -> [SkolemScope]

130130 collectSkolems = nub . everythingOnTypes (++) collect

131131 where

132− collect (Skolem _ _ scope) = [scope]

132+ collect (Skolem _ _ scope _) = [scope]

133133 collect _ = []

134134 go scos _ = (scos, [])

135135 findBindingScope :: SkolemScope -> Maybe Expr

src/Language/PureScript/TypeChecker/Subsumption.hs+1−1

@@ -55,7 +55,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

5555 case sco of

5656 Just sco' -> do

5757 sko <- newSkolemConstant

58− let sk = skolemize ident sko sco' ty2

58+ let sk = skolemize ident sko sco' Nothing ty2

5959 subsumes val ty1 sk

6060 Nothing -> internalError "subsumes: unspecified skolem scope"

6161subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

src/Language/PureScript/TypeChecker/Types.hs+7−4

@@ -406,9 +406,9 @@ inferBinder val (PositionedBinder pos _ binder) =

406406-- change the definition of `binderRequiresMonotype`,

407407-- and use `kindOfWithScopedVars`.

408408inferBinder val (TypedBinder ty binder) = do

409+ kind <- kindOf ty

410+ checkTypeKind ty kind

409411 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

410− kind <- kindOf ty1

411− checkTypeKind ty1 kind

412412 unifyTypes val ty1

413413 inferBinder val binder

414414

@@ -487,8 +487,11 @@ check' :: forall m.

487487check' val (ForAll ident ty _) = do

488488 scope <- newSkolemScope

489489 sko <- newSkolemConstant

490− let sk = skolemize ident sko scope ty

491− let skVal = skolemizeTypesInValue ident sko scope val

490+ let ss = case val of

491+ PositionedValue pos _ _ -> Just pos

492+ _ -> Nothing

493+ sk = skolemize ident sko scope ss ty

494+ skVal = skolemizeTypesInValue ident sko scope ss val

492495 val' <- check skVal sk

493496 return $ TypedValue True val' (ForAll ident ty (Just scope))

494497check' val t@(ConstrainedType constraints ty) = do

src/Language/PureScript/TypeChecker/Unify.hs+7−7

@@ -105,13 +105,13 @@ unifyTypes t1 t2 = do

105105 case (sc1, sc2) of

106106 (Just sc1', Just sc2') -> do

107107 sko <- newSkolemConstant

108− let sk1 = skolemize ident1 sko sc1' ty1

109− let sk2 = skolemize ident2 sko sc2' ty2

108+ let sk1 = skolemize ident1 sko sc1' Nothing ty1

109+ let sk2 = skolemize ident2 sko sc2' Nothing ty2

110110 sk1 `unifyTypes` sk2

111111 _ -> internalError "unifyTypes: unspecified skolem scope"

112112 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

113113 sko <- newSkolemConstant

114− let sk = skolemize ident sko sc ty1

114+ let sk = skolemize ident sko sc Nothing ty1

115115 sk `unifyTypes` ty2

116116 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"

117117 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

@@ -121,7 +121,7 @@ unifyTypes t1 t2 = do

121121 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

122122 t3 `unifyTypes` t5

123123 t4 `unifyTypes` t6

124− unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()

124+ unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return ()

125125 unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2

126126 unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2

127127 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

@@ -162,7 +162,7 @@ unifyRows r1 r2 =

162162 solveType u2 (rowFromList (sd1, rest))

163163 unifyRows' [] REmpty [] REmpty = return ()

164164 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

165− unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

165+ unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()

166166 unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2

167167

168168-- |

@@ -170,7 +170,7 @@ unifyRows r1 r2 =

170170--

171171unifiesWith :: Type -> Type -> Bool

172172unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True

173−unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True

173+unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True

174174unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True

175175unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

176176unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2

@@ -187,7 +187,7 @@ unifiesWith r1@RCons{} r2@RCons{} =

187187 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

188188 go [] REmpty [] REmpty = True

189189 go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2

190− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2

190+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

191191 go [] (TUnknown _) _ _ = True

192192 go _ _ [] (TUnknown _) = True

193193 go _ (TUnknown _) _ (TUnknown _) = True

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

@@ -34,6 +34,7 @@ import Control.Monad ((<=<))

3434import Language.PureScript.Names

3535import Language.PureScript.Kinds

3636import Language.PureScript.Traversals

37+import Language.PureScript.AST.SourcePos

3738

3839-- |

3940-- An identifier for the scope of a skolem variable

@@ -75,7 +76,7 @@ data Type

7576 -- |

7677 -- A skolem constant

7778 --

78− | Skolem String Int SkolemScope

79+ | Skolem String Int SkolemScope (Maybe SourceSpan)

7980 -- |

8081 -- An empty row

8182 --

tests/support/bower.json+1−1

@@ -2,7 +2,7 @@

22 "name": "purescript-test-suite-support",

33 "dependencies": {

44 "purescript-eff": "0.1.0",

5− "purescript-prelude": "0.1.1",

5+ "purescript-prelude": "0.1.3",

66 "purescript-assert": "0.1.1",

77 "purescript-st": "0.1.0",

88 "purescript-console": "0.1.0",