bf6cda5 · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

bf6cda5Andy Arvanitis11 years ago

CONTRIBUTORS.md+1

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

28- [@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).

29- [@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).

30- [@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).

31- [@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).

32- [@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).

32- [@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.

33- [@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.

33- [@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).

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

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

71 js <- liftIO (readFile filename)

72 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

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

psc-docs/Tags.hs+3−3

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

10 dtags _ = []

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

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

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

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

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

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

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

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

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

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

18 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−

16{-# LANGUAGE DoAndIfThenElse #-}

1{-# LANGUAGE DoAndIfThenElse #-}

17{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

19{-# LANGUAGE TupleSections #-}

4{-# LANGUAGE TupleSections #-}

6+-- |

7+-- PureScript Compiler Interactive.

8+--

21module PSCi where

9module PSCi where

23import Prelude ()

11import Prelude ()

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

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

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

334

322

335 showRef :: P.DeclarationRef -> String

323 showRef :: P.DeclarationRef -> String

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

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

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

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

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

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

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

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

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

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

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

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

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

342

331

343 commaList :: [String] -> String

332 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−

15{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

4+{-# LANGUAGE LambdaCase #-}

6+-- |

7+-- Data types for modules and declarations

8+--

19module Language.PureScript.AST.Declarations where

9module Language.PureScript.AST.Declarations where

21import Prelude ()

11import Prelude ()

22import Prelude.Compat

12import Prelude.Compat

24import Data.Aeson.TH

14import Data.Aeson.TH

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

16+import Data.Maybe (mapMaybe)

26import qualified Data.Data as D

18import qualified Data.Data as D

27import qualified Data.Map as M

19import qualified Data.Map as M

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

74 --

66 --

75 | ModuleRef ModuleName

67 | ModuleRef ModuleName

76 -- |

68 -- |

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

70+ -- or TypeRef during name desugaring.

71+ | ProperRef ProperName

72+ -- |

77 -- A declaration reference with source position information

73 -- A declaration reference with source position information

78 --

74 --

79 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

75 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

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

84 (ValueRef name) == (ValueRef name') = name == name'

80 (ValueRef name) == (ValueRef name') = name == name'

85 (TypeClassRef name) == (TypeClassRef name') = name == name'

81 (TypeClassRef name) == (TypeClassRef name') = name == name'

86 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

82 (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'

88 (PositionedDeclarationRef _ _ r) == r' = r == r'

85 (PositionedDeclarationRef _ _ r) == r' = r == r'

89 r == (PositionedDeclarationRef _ _ r') = r == r'

86 r == (PositionedDeclarationRef _ _ r') = r == r'

90 _ == _ = False

87 _ == _ = False

92isModuleRef :: DeclarationRef -> Bool

89isModuleRef :: DeclarationRef -> Bool

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

93isModuleRef (ModuleRef _) = True

91isModuleRef (ModuleRef _) = True

94isModuleRef _ = False

92isModuleRef _ = False

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+

96-- |

116-- |

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

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

98--

118--

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

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

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

110 --

130 --

111 | Hiding [DeclarationRef]

131 | Hiding [DeclarationRef]

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

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

113

133

114-- |

134-- |

115-- The data type of declarations

135-- The data type of declarations

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

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

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

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

120

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

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

123+

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

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

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

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

123 matches _ _ = False

126 matches _ _ = False

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

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

18import Prelude.Compat

20import Data.Maybe (mapMaybe)

21+import Data.List (mapAccumL)

22+import Data.Foldable (fold)

23+import qualified Data.Set as S

24+

21import Control.Monad

25import Control.Monad

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

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

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

25import Language.PureScript.AST.Declarations

29import Language.PureScript.AST.Declarations

26import Language.PureScript.Types

30import Language.PureScript.Types

27import Language.PureScript.Traversals

31import Language.PureScript.Traversals

32+import Language.PureScript.Names

29everywhereOnValues :: (Declaration -> Declaration) ->

34everywhereOnValues :: (Declaration -> Declaration) ->

30 (Expr -> Expr) ->

35 (Expr -> Expr) ->

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

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

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

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

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

391

396

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+

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

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

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

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

394 where

505 where

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

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

29import Prelude.Compat

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

32−import Data.Maybe (isNothing)

32+import Data.Maybe (isNothing, fromMaybe)

33+import qualified Data.Map as M

33import qualified Data.Traversable as T (traverse)

34import qualified Data.Traversable as T (traverse)

35import Control.Arrow ((&&&))

36import Control.Arrow ((&&&))

36import Control.Monad (replicateM, forM)

37import Control.Monad (replicateM, forM)

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

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

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

38import Control.Monad.Supply.Class

40import Control.Monad.Supply.Class

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

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

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

44import Language.PureScript.CoreFn

46import Language.PureScript.CoreFn

45import Language.PureScript.Names

47import Language.PureScript.Names

48+import Language.PureScript.Errors

46import Language.PureScript.CodeGen.JS.Optimizer

49import Language.PureScript.CodeGen.JS.Optimizer

47import Language.PureScript.Options

50import Language.PureScript.Options

48import Language.PureScript.Traversals (sndM)

51import Language.PureScript.Traversals (sndM)

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

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

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

55-- module.

58-- module.

56--

59--

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)

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

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

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

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

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

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

67+ let decls' = renameModules mnLookup decls

61− jsDecls <- mapM bindToJs decls

68+ jsDecls <- mapM bindToJs decls'

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

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

63− comments <- not <$> asks optionsNoComments

70+ comments <- not <$> asks optionsNoComments

64− let strict = JSStringLiteral "use strict"

71+ let strict = JSStringLiteral "use strict"

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

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

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

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

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

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

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

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

69− let standardExps = exps \\ foreignExps

76+ let standardExps = exps \\ foreignExps

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

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

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

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

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

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

74 where

81 where

76 -- |

83 -- |

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

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

78 --

85 --

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

79− importToJs :: ModuleName -> m JS

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

80− importToJs mn' = do

118+ importToJs mnLookup mn' = do

81 path <- asks optionsRequirePath

119 path <- asks optionsRequirePath

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

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

121 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

144

85 -- |

145 -- |

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

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

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

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

130 --

190 --

131 valueToJs :: Expr Ann -> m JS

191 valueToJs :: Expr Ann -> m JS

132− valueToJs (Literal _ l) =

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

133− literalToValueJS l

193+ maybe id rethrowWithPosition pos $ literalToValueJS l

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

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

135 return $ JSAccessor "value" $ qualifiedToJS id name

195 return $ JSAccessor "value" $ qualifiedToJS id name

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

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

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

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

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

208

268

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

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

211 literalToValueJS (StringLiteral s) = return $ JSStringLiteral s

277 literalToValueJS (StringLiteral s) = return $ JSStringLiteral s

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

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

213 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b

279 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b

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

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

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

276

342

277 failedPatternError :: [String] -> JS

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

279

345

280− errorMessage :: String

346+ failedPatternMessage :: String

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

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

282

348

283 valueError :: String -> JS -> JS

349 valueError :: String -> JS -> JS

284 valueError _ l@(JSNumericLiteral _) = l

350 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−

15{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RecordWildCards #-}

17{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

19module Language.PureScript.Errors where

6module Language.PureScript.Errors where

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

24import Data.Ord (comparing)

11import Data.Ord (comparing)

25import Data.Either (lefts, rights)

12import Data.Either (lefts, rights)

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

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

27−import Data.Function (on)

28import Data.Foldable (fold)

14import Data.Foldable (fold)

30import qualified Data.Map as M

16import qualified Data.Map as M

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

33import Control.Monad.Writer

19import Control.Monad.Writer

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

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

35import Control.Monad.Trans.State.Lazy

21import Control.Monad.Trans.State.Lazy

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

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

38import Language.PureScript.Crash

24import Language.PureScript.Crash

39import Language.PureScript.AST

25import Language.PureScript.AST

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

143 | UnusedDctorImport ProperName

129 | UnusedDctorImport ProperName

144 | UnusedDctorExplicitImport ProperName [ProperName]

130 | UnusedDctorExplicitImport ProperName [ProperName]

145 | DeprecatedQualifiedSyntax ModuleName ModuleName

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

146 deriving (Show)

141 deriving (Show)

147

142

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

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

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

278 UnusedDctorImport{} -> "UnusedDctorImport"

273 UnusedDctorImport{} -> "UnusedDctorImport"

279 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

280 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

275 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"

281

285

282

286

283-- |

287-- |

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

311addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

315addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors

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

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

313

317

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−

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

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

319

328

320-- | How critical the issue is

329-- | How critical the issue is

321data Level = Error | Warning deriving Show

330data Level = Error | Warning deriving Show

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

326unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

335unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage

327unwrapErrorMessage (ErrorMessage _ se) = se

336unwrapErrorMessage (ErrorMessage _ se) = se

328

337

329−replaceUnknowns :: Type -> State UnknownMap Type

338+replaceUnknowns :: Type -> State TypeMap Type

330replaceUnknowns = everywhereOnTypesM replaceTypes

339replaceUnknowns = everywhereOnTypesM replaceTypes

331 where

340 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

341+ replaceTypes :: Type -> State TypeMap Type

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

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

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

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)

340 replaceTypes other = return other

358 replaceTypes other = return other

341

359

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

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

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

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

344 where

362 where

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

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

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

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

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

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

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

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

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

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

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

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+

351− gSimple other = pure other

378+ gSimple other = pure other

379+

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

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

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

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

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

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

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

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

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

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

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

357− gHint other = pure other

386+ gHint other = pure other

358

387

359-- |

388-- |

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

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

361--

390--

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

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

392+prettyPrintSingleError full level e = do

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

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

394+ um <- get

395+ return (prettyPrintErrorMessage um em)

364 where

396 where

365

397

366 -- Pretty print an ErrorMessage

398 -- Pretty print an ErrorMessage

367− prettyPrintErrorMessage :: ErrorMessage -> Box.Box

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

368− prettyPrintErrorMessage (ErrorMessage hints simple) =

400+ prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

369− paras $

401+ paras

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

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

403+ , Box.moveDown 1 typeInformation

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

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

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

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

373 ]

406 ]

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

376 wikiUri :: String

409 wikiUri :: String

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

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

378

411

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+

379 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

429 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

380 renderSimpleErrorMessage (CannotGetFileInfo path) =

430 renderSimpleErrorMessage (CannotGetFileInfo path) =

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

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

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

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

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

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

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

578 ]

628 ]

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

630+ | any containsUnknowns ts

631+ ]

579 ]

632 ]

633+ where

634+ containsUnknowns :: Type -> Bool

635+ containsUnknowns = everythingOnTypes (||) go

636+ where

637+ go TUnknown{} = True

638+ go _ = False

580 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

639 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

581 paras [ line "Type class instance for"

640 paras [ line "Type class instance for"

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

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

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

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

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

716

775

717 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

776 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

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:"

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

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

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

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."

720

821

721 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

822 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

722 renderHint (ErrorUnifyingTypes t1 t2) detail =

823 renderHint (ErrorUnifyingTypes t1 t2) detail =

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

849 -- Pretty print and export declaration

950 -- Pretty print and export declaration

850 prettyPrintExport :: DeclarationRef -> String

951 prettyPrintExport :: DeclarationRef -> String

851 prettyPrintExport (TypeRef pn _) = runProperName pn

952 prettyPrintExport (TypeRef pn _) = runProperName pn

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

852− prettyPrintExport (ValueRef ident) = showIdent ident

958+ prettyPrintRef (ValueRef ident) = showIdent ident

853− prettyPrintExport (TypeClassRef pn) = runProperName pn

959+ prettyPrintRef (TypeClassRef pn) = runProperName pn

960+ prettyPrintRef (ProperRef pn) = runProperName pn

854− prettyPrintExport (TypeInstanceRef ident) = showIdent ident

961+ prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

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

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

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

857

972

858 -- | Simplify an error message

973 -- | Simplify an error message

859 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

974 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

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

878 hintCategory ErrorUnifyingTypes{} = CheckHint

993 hintCategory ErrorUnifyingTypes{} = CheckHint

879 hintCategory ErrorInSubsumption{} = CheckHint

994 hintCategory ErrorInSubsumption{} = CheckHint

880 hintCategory ErrorInApplication{} = CheckHint

995 hintCategory ErrorInApplication{} = CheckHint

996+ hintCategory ErrorCheckingKind{} = CheckHint

881 hintCategory PositionedError{} = PositionHint

997 hintCategory PositionedError{} = PositionHint

882 hintCategory _ = OtherHint

998 hintCategory _ = OtherHint

883

999

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

895

1011

896-- | Pretty print warnings as a Box

1012-- | Pretty print warnings as a Box

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

1013prettyPrintMultipleWarningsBox :: 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

899

1015

900-- | Pretty print errors as a Box

1016-- | Pretty print errors as a Box

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

1017prettyPrintMultipleErrorsBox :: 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

903

1019

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

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

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

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

906 result <- prettyPrintSingleError full level e

1022 result <- prettyPrintSingleError full level e

907 return $

1023 return $

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

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

15{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

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

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

20import Prelude ()

21import Prelude ()

21import Prelude.Compat

22import Prelude.Compat

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

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

24import Data.Maybe (mapMaybe)

25import Data.Maybe (mapMaybe)

25import Data.Monoid

26import Data.Monoid

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

54 getDeclIdent _ = Nothing

55 getDeclIdent _ = Nothing

56 lintDeclaration :: Declaration -> m ()

57 lintDeclaration :: Declaration -> m ()

57− lintDeclaration d =

58+ lintDeclaration = tell . f

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)

67 where

59 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

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

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

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

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'

72 where

93 where

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

94+ go d | Just i <- getDeclIdent d

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

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

96+ | otherwise = mempty

97+ stepDo _ _ = mempty

95 checkTypeVarsInDecl :: Declaration -> MultipleErrors

99 checkTypeVarsInDecl :: Declaration -> MultipleErrors

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

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

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

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

9import qualified Data.Map as M

10import Data.Maybe (mapMaybe)

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

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

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

13import Control.Monad.Writer.Class

14−import Control.Monad(unless,when)

14+import Control.Monad (unless,when)

15import Data.Foldable (forM_)

17import Language.PureScript.AST.Declarations

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

25import qualified Language.PureScript.Constants as C

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

28+data Name

29+ = IdentName (Qualified Ident)

30+ | TypeName (Qualified ProperName)

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

31+ | DctorName (Qualified ProperName)

32+ | ClassName (Qualified ProperName)

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

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

31type UsedImports = M.Map ModuleName [Name]

35type UsedImports = M.Map ModuleName [Name]

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

46 in case declType of

50 in case declType of

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

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

48 Explicit declrefs -> do

52 Explicit declrefs -> do

49− let idents = mapMaybe runDeclRef declrefs

53+ let idents = nub (mapMaybe runDeclRef declrefs)

50 let diff = idents \\ usedNames

54 let diff = idents \\ usedNames

51 case (length diff, length idents) of

55 case (length diff, length idents) of

52 (0, _) -> return ()

56 (0, _) -> return ()

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

63 let ddiff = ctors \\ usedDctors

67 let ddiff = ctors \\ usedDctors

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

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

65 _ -> return ()

69 _ -> return ()

70+

66 return ()

71 return ()

68 _ -> return ()

73 _ -> return ()

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

74 -- rely on exports being elaborated by this point

79 -- rely on exports being elaborated by this point

75 alwaysUsedModules :: [ ModuleName ]

80 alwaysUsedModules :: [ ModuleName ]

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

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

77 where

82 where

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

78− isExport (ModuleRef mn) = Just mn

84+ extractModule (ModuleRef mn) = Just mn

79− isExport _ = Nothing

85+ extractModule _ = Nothing

81 qnameUsed :: Maybe ModuleName -> Bool

87 qnameUsed :: Maybe ModuleName -> Bool

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

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

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

102

108

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

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

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

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

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

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

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

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

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

107matchName _ _ _ = Nothing

114matchName _ _ _ = Nothing

108

115

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

114runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

121runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

115runDeclRef (ValueRef ident) = Just $ showIdent ident

122runDeclRef (ValueRef ident) = Just $ showIdent ident

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

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

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

117runDeclRef _ = Nothing

125runDeclRef _ = Nothing

118

126

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

127getTypeRef :: 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−

16{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

18{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE TupleSections #-}

5+-- |

6+-- Parsers for module definitions and declarations

7+--

20module Language.PureScript.Parser.Declarations (

8module Language.PureScript.Parser.Declarations (

21 parseDeclaration,

9 parseDeclaration,

22 parseModule,

10 parseModule,

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

170

158

171parseDeclarationRef :: TokenParser DeclarationRef

159parseDeclarationRef :: TokenParser DeclarationRef

172parseDeclarationRef =

160parseDeclarationRef =

173− parseModuleRef <|>

174 withSourceSpan PositionedDeclarationRef

161 withSourceSpan PositionedDeclarationRef

175− (ValueRef <$> parseIdent

162+ $ (ValueRef <$> parseIdent)

176− <|> do name <- properName

163+ <|> parseProperRef

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

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

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

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

179− )

180 where

166 where

181− parseModuleRef :: TokenParser DeclarationRef

167+ parseProperRef = do

182− parseModuleRef = do

168+ name <- properName

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

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

184− return $ ModuleRef name

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

185

171

186parseTypeClassDeclaration :: TokenParser Declaration

172parseTypeClassDeclaration :: TokenParser Declaration

187parseTypeClassDeclaration = do

173parseTypeClassDeclaration = do

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

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

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

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

47 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

49 match REmpty = Just $ text "()"

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

51 match _ = Nothing

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

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

102collapseBindingGroupsForValue other = other

103

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

105−usedIdents moduleName =

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

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

107− in nub . f

108 where

106 where

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

107+ def _ _ = []

110

108

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

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

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

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

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

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

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

112+ getValue _ = internalError "Expected ValueDeclaration"

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

113+

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

116

115

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

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

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

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 _ _ = []

119

120

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

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

121usedImmediateIdents moduleName =

122usedImmediateIdents 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−

14{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

15{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE RecordWildCards #-}

16{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

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

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

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

50desugarImports externs modules = do

37desugarImports externs modules = do

51 env <- silence $ foldM externsEnv primEnv externs

38 env <- silence $ foldM externsEnv primEnv externs

39+ modules' <- traverse updateExportRefs modules

52− env' <- foldM updateEnv env modules

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

53− traverse (renameInModule' env') modules

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

54 where

42 where

55 silence :: m a -> m a

43 silence :: m a -> m a

56 silence = censor (const mempty)

44 silence = censor (const mempty)

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

90 toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

78 toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

91 toExportedValue _ = Nothing

79 toExportedValue _ = Nothing

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

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

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

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

95 case mn `M.lookup` env of

83 case mn `M.lookup` env of

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

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

97 Nothing -> do

85 Nothing -> do

98 members <- findExportable m

86 members <- findExportable m

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

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

100− imps <- resolveImports env' m

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

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

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

103

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

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

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

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

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

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

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

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

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

109 findUnusedImports m env used

97 findUnusedImports m env used

110− return $ elaborateImports imps m'

98+ return m'

111

112-- |

100-- |

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

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

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

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

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

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

129

117

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−

147-- |

118-- |

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

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

149-- qualified names are valid.

120-- qualified names are valid.

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

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

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

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

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

173 updateDecl s d = return (s, d)

144 updateDecl s d = return (s, d)

174− --

145+

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

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

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

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

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

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

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

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

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

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

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

194 updateValue s v = return (s, v)

165 updateValue s v = return (s, v)

195− --

166+

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

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

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

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

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

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

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

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

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

205 updateBinder s v =

176 updateBinder s v =

206 return (s, v)

177 return (s, v)

207− --

178+

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

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

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

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

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

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

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

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

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

227

198

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

199 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

230

201

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

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

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

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

233

204

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

205 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

236

207

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

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

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

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

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

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

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

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

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

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

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

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

283− modExports <- getExports mn''

253+ modExports <- getExports env mn''

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

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

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

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

286 -- unimported symbol.

256 -- unimported symbol.

287 _ -> throwError . errorMessage $ unknown qname

257 _ -> throwError . errorMessage $ unknown qname

288 where

258 where

289− isExplicitQualModule :: ModuleName -> Bool

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

291 positioned err = case pos of

259 positioned err = case pos of

292 Nothing -> err

260 Nothing -> err

293 Just pos' -> rethrowWithPosition pos' err

261 Just pos' -> rethrowWithPosition pos' err

294

262

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

263+-- |

296− getExports :: ModuleName -> m Exports

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

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

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−

14{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

16module Language.PureScript.Sugar.Names.Env

3module Language.PureScript.Sugar.Names.Env

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

26 , exportType

13 , exportType

27 , exportTypeClass

14 , exportTypeClass

28 , exportValue

15 , exportValue

16+ , getExports

29 ) where

17 ) where

31import qualified Data.Map as M

19import qualified Data.Map as M

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

189--

177--

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

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

191throwConflictError conflict = throwError . errorMessage . conflict

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

15{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TupleSections #-}

18+{-# LANGUAGE LambdaCase #-}

19module Language.PureScript.Sugar.Names.Exports

20module Language.PureScript.Sugar.Names.Exports

20 ( findExportable

21 ( findExportable

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

29import Data.Foldable (traverse_)

30import Data.Foldable (traverse_)

31import Control.Monad

32import Control.Monad

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

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

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

34import qualified Data.Map as M

36import qualified Data.Map as M

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

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

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

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

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

68--

70--

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

70resolveExports env mn imps exps refs =

72resolveExports env mn imps exps refs =

71 rethrow (addHint (ErrorInModule mn)) $ do

73 rethrow (addHint (ErrorInModule mn)) $ do

72 filtered <- filterModule mn exps refs

74 filtered <- filterModule mn exps refs

75+ let (dupeRefs, dupeDctors) = findDuplicateRefs refs

76+ warnDupeRefs dupeRefs

77+ warnDupeDctors dupeDctors

73 foldM elaborateModuleExports filtered refs

78 foldM elaborateModuleExports filtered refs

75 where

80 where

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+

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

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

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

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

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

98 -- 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−

14{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

15{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE TupleSections #-}

4+{-# LANGUAGE LambdaCase #-}

18module Language.PureScript.Sugar.Names.Imports

6module Language.PureScript.Sugar.Names.Imports

19 ( resolveImports

7 ( resolveImports

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

24import Prelude ()

12import Prelude ()

25import Prelude.Compat

13import Prelude.Compat

27−import Data.List (find)

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

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

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

29−import Data.Foldable (traverse_)

17+import Data.Foldable (traverse_, for_)

18+import Data.Traversable (for)

31import Control.Arrow (first)

20import Control.Arrow (first)

32import Control.Monad

21import Control.Monad

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

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

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

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

36import qualified Data.Map as M

25import qualified Data.Map as M

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

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

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

46-- explicitly imported declarations.

35-- explicitly imported declarations.

47--

36--

37+findImports

38+ :: forall m

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

40+ => [Declaration]

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

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

49findImports = foldM (go Nothing) M.empty

42findImports = foldM (go Nothing) M.empty

50 where

43 where

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

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

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

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

53− checkImportRefType typ

54 let imp = (pos, typ, qual)

46 let imp = (pos, typ, qual)

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

47 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

57 go _ result _ = return result

49 go _ result _ = return result

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

60− checkImportRefType :: ImportDeclarationType -> m ()

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

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

67-- |

53-- |

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

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

69--

55--

56+resolveImports

57+ :: forall m

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

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

59+ => Env

60+ -> Module

61+ -> m (Module, Imports)

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

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

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

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+

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

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

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

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

157

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

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

77−resolveModuleImport ::

159+resolveModuleImport

160+ :: forall m

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

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

162+ => ModuleName

163+ -> Env

79− ModuleName -> Env -> Imports ->

164+ -> Imports

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

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

81− m Imports

166+ -> m Imports

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

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

83 where

168 where

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

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

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

94-- |

179-- |

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

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

96--

181--

182+resolveImport

183+ :: forall m

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

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

98−resolveImport currentModule importModule exps imps impQual =

192+resolveImport currentModule importModule exps imps impQual = resolveByType

99− resolveByType

100 where

193 where

101

194

102 resolveByType :: ImportDeclarationType -> m Imports

195 resolveByType :: ImportDeclarationType -> m Imports

103 resolveByType Implicit = importAll importExplicit

196 resolveByType Implicit = importAll importExplicit

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

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

198+ resolveByType (Hiding refs) = do

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

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'

106

207

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

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

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

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

109− checkRefs = traverse_ check

210+ checkRefs isHiding = traverse_ check

110 where

211 where

111 check (PositionedDeclarationRef pos _ r) =

212 check (PositionedDeclarationRef pos _ r) =

112 rethrowWithPosition pos $ check r

213 rethrowWithPosition pos $ check r

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

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

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

119 check (TypeClassRef name) =

220 check (TypeClassRef name) =

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

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

121− --check (ModuleRef name) =

222+ check (ModuleRef name) | isHiding =

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

223+ throwError . errorMessage $ ImportHidingModule name

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

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

124

225

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

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

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

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

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

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

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

187

288

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

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

290+ updateImports

291+ :: (Ord a)

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

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

190− -> (a -> String)

293+ -> (a -> String)

191− -> [(a, ModuleName)]

294+ -> [(a, ModuleName)]

192− -> a

295+ -> a

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

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

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

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

195

298

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

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

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

148--

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

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

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

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

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

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

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

164 <*> go sd1 r1' sd2 r2'

165 where

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

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

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

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

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

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

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

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

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

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

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

172− go _ _ _ _ = Nothing

172+ go _ _ _ _ = Nothing

173typeHeadsAreEqual _ _ _ = Nothing

174

175-- |

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

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

226 go (TypeVar v) = do

227 Just moduleName <- checkCurrentModule <$> get

228 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

229− go (Skolem v _ _) = do

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

230 Just moduleName <- checkCurrentModule <$> get

231 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

232 go (TypeConstructor v) = do

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

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

71-- |

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

73--

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

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

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

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

77-- |

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

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

80-- only example of scoped type variables.

81--

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

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

83−skolemizeTypesInValue ident sko scope =

83+skolemizeTypesInValue ident sko scope ss =

84 let

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

86 in runIdentity . f

87 where

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

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

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

93 onExpr sco other = return (sco, other)

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

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

98 onBinder sco other = return (sco, other)

100 peelTypeVars :: Type -> [String]

@@ -129,7 +129,7 @@ skolemEscapeCheck root@TypedValue{} =

129 collectSkolems :: Type -> [SkolemScope]

130 collectSkolems = nub . everythingOnTypes (++) collect

131 where

132− collect (Skolem _ _ scope) = [scope]

132+ collect (Skolem _ _ scope _) = [scope]

133 collect _ = []

134 go scos _ = (scos, [])

135 findBindingScope :: SkolemScope -> Maybe Expr

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

@@ -55,7 +55,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

55 case sco of

56 Just sco' -> do

57 sko <- newSkolemConstant

58− let sk = skolemize ident sko sco' ty2

58+ let sk = skolemize ident sko sco' Nothing ty2

59 subsumes val ty1 sk

60 Nothing -> internalError "subsumes: unspecified skolem scope"

61subsumes' 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) =

406-- change the definition of `binderRequiresMonotype`,

407-- and use `kindOfWithScopedVars`.

408inferBinder val (TypedBinder ty binder) = do

409+ kind <- kindOf ty

410+ checkTypeKind ty kind

409 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

411 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

410− kind <- kindOf ty1

411− checkTypeKind ty1 kind

412 unifyTypes val ty1

413 inferBinder val binder

414

@@ -487,8 +487,11 @@ check' :: forall m.

487check' val (ForAll ident ty _) = do

488 scope <- newSkolemScope

489 sko <- newSkolemConstant

490+ let ss = case val of

491+ PositionedValue pos _ _ -> Just pos

492+ _ -> Nothing

490− let sk = skolemize ident sko scope ty

493+ sk = skolemize ident sko scope ss ty

491− let skVal = skolemizeTypesInValue ident sko scope val

494+ skVal = skolemizeTypesInValue ident sko scope ss val

492 val' <- check skVal sk

495 val' <- check skVal sk

493 return $ TypedValue True val' (ForAll ident ty (Just scope))

496 return $ TypedValue True val' (ForAll ident ty (Just scope))

494check' val t@(ConstrainedType constraints ty) = do

497check' val t@(ConstrainedType constraints ty) = do

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

@@ -105,13 +105,13 @@ unifyTypes t1 t2 = do

105 case (sc1, sc2) of

106 (Just sc1', Just sc2') -> do

107 sko <- newSkolemConstant

108− let sk1 = skolemize ident1 sko sc1' ty1

108+ let sk1 = skolemize ident1 sko sc1' Nothing ty1

109− let sk2 = skolemize ident2 sko sc2' ty2

109+ let sk2 = skolemize ident2 sko sc2' Nothing ty2

110 sk1 `unifyTypes` sk2

111 _ -> internalError "unifyTypes: unspecified skolem scope"

112 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

113 sko <- newSkolemConstant

114− let sk = skolemize ident sko sc ty1

114+ let sk = skolemize ident sko sc Nothing ty1

115 sk `unifyTypes` ty2

116 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"

117 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

@@ -121,7 +121,7 @@ unifyTypes t1 t2 = do

121 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

122 t3 `unifyTypes` t5

123 t4 `unifyTypes` t6

124− unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()

124+ unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return ()

125 unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2

126 unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2

127 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

@@ -162,7 +162,7 @@ unifyRows r1 r2 =

162 solveType u2 (rowFromList (sd1, rest))

163 unifyRows' [] REmpty [] REmpty = return ()

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

166 unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2

167

168-- |

@@ -170,7 +170,7 @@ unifyRows r1 r2 =

170--

171unifiesWith :: Type -> Type -> Bool

172unifiesWith (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

174unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True

175unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

176unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2

@@ -187,7 +187,7 @@ unifiesWith r1@RCons{} r2@RCons{} =

187 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

188 go [] REmpty [] REmpty = True

189 go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2

190− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2

190+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

191 go [] (TUnknown _) _ _ = True

192 go _ _ [] (TUnknown _) = True

193 go _ (TUnknown _) _ (TUnknown _) = True

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

@@ -34,6 +34,7 @@ import Control.Monad ((<=<))

34import Language.PureScript.Names

35import Language.PureScript.Kinds

36import Language.PureScript.Traversals

37+import Language.PureScript.AST.SourcePos

38-- |

39-- |

39-- An identifier for the scope of a skolem variable

40-- An identifier for the scope of a skolem variable

@@ -75,7 +76,7 @@ data Type

75 -- |

76 -- |

76 -- A skolem constant

77 -- A skolem constant

77 --

78 --

78− | Skolem String Int SkolemScope

79+ | Skolem String Int SkolemScope (Maybe SourceSpan)

79 -- |

80 -- |

80 -- An empty row

81 -- An empty row

81 --

82 --

tests/support/bower.json+1−1

@@ -2,7 +2,7 @@

2 "name": "purescript-test-suite-support",

3 "dependencies": {

4 "purescript-eff": "0.1.0",

5− "purescript-prelude": "0.1.1",

5+ "purescript-prelude": "0.1.3",

6 "purescript-assert": "0.1.1",

7 "purescript-st": "0.1.0",

8 "purescript-console": "0.1.0",