dccc7af · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1684 from purescript/class-ref-keyword

dccc7afGary Burgess11 years ago

examples/passing/ClassRefSyntax.pursnew file+13

compare with golang

unifiedsplit

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

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+10−15

@@ -1,22 +1,11 @@

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 #-}

18{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE LambdaCase #-}

6+-- |

7+-- Data types for modules and declarations

8+--

20module Language.PureScript.AST.Declarations where

9module Language.PureScript.AST.Declarations where

22import Prelude ()

11import Prelude ()

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

77 --

66 --

78 | ModuleRef ModuleName

67 | ModuleRef ModuleName

79 -- |

68 -- |

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

70+ -- or TypeRef during name desugaring.

71+ | ProperRef ProperName

72+ -- |

80 -- A declaration reference with source position information

73 -- A declaration reference with source position information

81 --

74 --

82 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

75 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

@@ -87,12 +80,14 @@ instance Eq DeclarationRef where

87 (ValueRef name) == (ValueRef name') = name == name'

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

88 (TypeClassRef name) == (TypeClassRef name') = name == name'

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

89 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

82 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

90− (ModuleRef name) == (ModuleRef name') = name == name'

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

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

91 (PositionedDeclarationRef _ _ r) == r' = r == r'

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

92 r == (PositionedDeclarationRef _ _ r') = r == r'

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

93 _ == _ = False

87 _ == _ = False

95isModuleRef :: DeclarationRef -> Bool

89isModuleRef :: DeclarationRef -> Bool

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

96isModuleRef (ModuleRef _) = True

91isModuleRef (ModuleRef _) = True

97isModuleRef _ = False

92isModuleRef _ = False

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/Errors.hs+27−16

@@ -1,17 +1,3 @@

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 #-}

17{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

@@ -143,6 +129,8 @@ 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

146 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

147 | DuplicateSelectiveImport ModuleName

135 | DuplicateSelectiveImport ModuleName

148 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

@@ -285,6 +273,8 @@ errorCode em = case unwrapErrorMessage em of

285 UnusedDctorImport{} -> "UnusedDctorImport"

273 UnusedDctorImport{} -> "UnusedDctorImport"

286 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

287 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

275 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

276+ DeprecatedClassImport{} -> "DeprecatedClassImport"

277+ DeprecatedClassExport{} -> "DeprecatedClassExport"

288 RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

278 RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

289 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

279 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

290 DuplicateImport{} -> "DuplicateImport"

280 DuplicateImport{} -> "DuplicateImport"

@@ -784,8 +774,28 @@ prettyPrintSingleError full level e = do

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

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

785

775

786 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

776 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

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

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

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

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

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

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

782+ ]

783+

784+ renderSimpleErrorMessage (DeprecatedClassImport mn name) =

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

786+ , indent $ line $ runProperName name

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

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

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

790+ ]

791+

792+ renderSimpleErrorMessage (DeprecatedClassExport name) =

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

794+ , indent $ line $ runProperName name

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

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

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

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

798+ ]

789

799

790 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

800 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

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

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

@@ -947,6 +957,7 @@ prettyPrintSingleError full level e = do

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

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

948 prettyPrintRef (ValueRef ident) = showIdent ident

958 prettyPrintRef (ValueRef ident) = showIdent ident

949 prettyPrintRef (TypeClassRef pn) = runProperName pn

959 prettyPrintRef (TypeClassRef pn) = runProperName pn

960+ prettyPrintRef (ProperRef pn) = runProperName pn

950 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

961 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

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

952 prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

963 prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

src/Language/PureScript/Linter/Imports.hs+5−4

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

11import 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

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

79 -- rely on exports being elaborated by this point

80 alwaysUsedModules :: [ ModuleName ]

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

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

82 where

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

83− isExport (ModuleRef mn) = Just mn

84+ extractModule (ModuleRef mn) = Just mn

84− isExport _ = Nothing

85+ extractModule _ = Nothing

86 qnameUsed :: Maybe ModuleName -> Bool

87 qnameUsed :: Maybe ModuleName -> Bool

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

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

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/Sugar/Names.hs+37−23

@@ -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 _ _) =

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

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

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

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

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

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

265− modExports <- getExports mn''

253+ modExports <- getExports env mn''

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

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

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

268 -- unimported symbol.

256 -- unimported symbol.

@@ -272,6 +260,32 @@ renameInModule env imports (Module ss coms mn decls exps) =

272 Nothing -> err

260 Nothing -> err

273 Just pos' -> rethrowWithPosition pos' err

261 Just pos' -> rethrowWithPosition pos' err

274

262

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

263+-- |

276− getExports :: ModuleName -> m Exports

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

277− 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/Imports.hs+74−49

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

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 #-}

@@ -47,34 +34,36 @@ import Language.PureScript.Sugar.Names.Env

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

48-- explicitly imported declarations.

35-- explicitly imported declarations.

49--

36--

37+findImports

38+ :: forall m

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

40+ => [Declaration]

50−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)])

51findImports = foldM (go Nothing) M.empty

42findImports = foldM (go Nothing) M.empty

52 where

43 where

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

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

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

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

55− checkImportRefType typ

56 let imp = (pos, typ, qual)

46 let imp = (pos, typ, qual)

57 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

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

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

59 go _ result _ = return result

49 go _ result _ = return result

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

62− checkImportRefType :: ImportDeclarationType -> m ()

63− checkImportRefType (Hiding refs) = traverse_ checkImportRef refs

64− checkImportRefType _ = return ()

65− checkImportRef :: DeclarationRef -> m ()

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

67− checkImportRef _ = return ()

68−

69type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

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

71-- |

53-- |

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

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

73--

55--

56+resolveImports

57+ :: forall m

74−resolveImports :: forall m. (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)

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

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

76 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

63 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

64+

65+ decls' <- traverse updateImportRef decls

77− imports <- findImports decls

66+ imports <- findImports decls'

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

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

@@ -110,7 +99,8 @@ resolveImports env (Module _ _ currentModule decls _) =

110 return ()

99 return ()

111

100

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

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

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

114

104

115 where

105 where

116 selfCartesianSubset :: [a] -> [(a, a)]

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

@@ -142,12 +132,38 @@ resolveImports env (Module _ _ currentModule decls _) =

142 warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()

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

143 warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg

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

144

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+

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

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

146−resolveModuleImport ::

159+resolveModuleImport

160+ :: forall m

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

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

162+ => ModuleName

163+ -> Env

148− ModuleName -> Env -> Imports ->

164+ -> Imports

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

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

150− m Imports

166+ -> m Imports

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

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

152 where

168 where

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

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

@@ -163,17 +179,24 @@ resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

163-- |

179-- |

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

165--

181--

182+resolveImport

183+ :: forall m

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

167−resolveImport currentModule importModule exps imps impQual =

192+resolveImport currentModule importModule exps imps impQual = resolveByType

168− resolveByType

169 where

193 where

170

194

171 resolveByType :: ImportDeclarationType -> m Imports

195 resolveByType :: ImportDeclarationType -> m Imports

172 resolveByType Implicit = importAll importExplicit

196 resolveByType Implicit = importAll importExplicit

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

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

174− resolveByType (Hiding hiddenImports) = do

198+ resolveByType (Hiding refs) = do

175− checkRefs hiddenImports

176− imps' <- importAll (importNonHidden hiddenImports)

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

177 let isEmptyImport

200 let isEmptyImport

178 = M.null (importedTypes imps')

201 = M.null (importedTypes imps')

179 && M.null (importedDataConstructors imps')

202 && M.null (importedDataConstructors imps')

@@ -183,8 +206,8 @@ resolveImport currentModule importModule exps imps impQual =

183 return imps'

206 return imps'

184

207

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

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

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

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

187− checkRefs = traverse_ check

210+ checkRefs isHiding = traverse_ check

188 where

211 where

189 check (PositionedDeclarationRef pos _ r) =

212 check (PositionedDeclarationRef pos _ r) =

190 rethrowWithPosition pos $ check r

213 rethrowWithPosition pos $ check r

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

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

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

197 check (TypeClassRef name) =

220 check (TypeClassRef name) =

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

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

199− --check (ModuleRef name) =

222+ check (ModuleRef name) | isHiding =

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

223+ throwError . errorMessage $ ImportHidingModule name

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

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

202

225

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

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

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

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

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

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

265

288

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

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

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

268− -> (a -> String)

293+ -> (a -> String)

269− -> [(a, ModuleName)]

294+ -> [(a, ModuleName)]

270− -> a

295+ -> a

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

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

272 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

273

298

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