9b1315b · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'upstream/master' into pure11-0.8

commit9b1315be2b6ee114e863299f8915646124212db3 authorAndy Arvanitis <andyarvanitis@gmail.com> dateTue 19 Jan 2016, 20:35 (11 years ago) parent800e33c d1c7635

93 files changed+2819−1374

compare with golang

unifiedsplit

.gitignore+2

@@ -16,3 +16,5 @@ tmp/

1616.stack-work/

1717tests/support/flattened/

1818output

19+examples/docs/docs/

20+core-tests/full-core-docs.md

.travis.yml+2

@@ -57,6 +57,8 @@ install:

5757 # Snapshot state of the sandbox now, so we don't need to make new one for test install

5858 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

5959 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

60+ # Install bower globally (for psc-docs/psc-publish tests)

61+ - npm install -g bower

6062script:

6163 - ./travis/configure.sh

6264 - cabal build --ghc-options="-Werror"

CONTRIBUTORS.md+3

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

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

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

1414- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, 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).

15+- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, 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).

1516- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, 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).

1617- [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, 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).

1718- [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, 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).

@@ -60,6 +61,8 @@ This file lists the contributors to the PureScript compiler project, and the ter

6061<http://opensource.org/licenses/MIT>.

6162- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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).

6263- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, 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).

64+- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, 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).

65+- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, 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).

6366

6467### Companies

6568

INSTALL.md+1−1

@@ -27,7 +27,7 @@ GHC 7.6.1 or newer is required to compile from source. The easiest way is to

2727use stack:

2828

2929```

30−$ stack install purescript

30+$ stack install --resolver lts purescript

3131```

3232

3333This will then copy the compiler and utilities into `~/.local/bin`.

core-tests/test-everything.sh+5−3

@@ -18,9 +18,7 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then

1818 rm -r bower_components

1919fi

2020

21−npm install bower

22−

23−node_modules/.bin/bower i \

21+bower i \

2422 purescript-prelude \

2523 purescript-eff \

2624 purescript-st \

@@ -75,3 +73,7 @@ fi

7573../dist/build/psc/psc tests/*/*.purs \

7674 'bower_components/purescript-*/src/**/*.purs' \

7775 --ffi 'bower_components/purescript-*/src/**/*.js'

76+

77+../dist/build/psc-docs/psc-docs tests/*/*.purs \

78+ 'bower_components/purescript-*/src/**/*.purs' \

79+ > full-core-docs.md

examples/docs/bower.jsonnew file+19

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

1+{

2+ "name": "docs-test-package",

3+ "version": "1.0.0",

4+ "moduleType": [

5+ "node"

6+ ],

7+ "repository": {

8+ "type": "git",

9+ "url": "git://github.com/not-real/not-a-real-repo.git"

10+ },

11+ "ignore": [

12+ "**/.*",

13+ "node_modules",

14+ "bower_components",

15+ "output"

16+ ],

17+ "dependencies": {

18+ }

19+}

examples/docs/bower_components/purescript-prelude/src/Prelude.pursnew file+8

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

1+module Prelude where

3+newtype Unit = Unit {}

5+unit :: Unit

6+unit = Unit {}

8+data Boolean2 = True | False

examples/docs/src/Clash.pursnew file+32

@@ -0,0 +1,32 @@

1+module Clash (module Clash1) where

3+import Clash1 as Clash1

4+import Clash2 as Clash2

6+module Clash1 (module Clash1a) where

8+import Clash1a

10+module Clash1a where

11+

12+value :: Int

13+value = 0

14+

15+type Type = Int

16+

17+class TypeClass a where

18+ typeClassMember :: a

19+

20+module Clash2 (module Clash2a) where

21+

22+import Clash2a

23+

24+module Clash2a where

25+

26+value :: String

27+value = "hello"

28+

29+type Type = String

30+

31+class TypeClass a b where

32+ typeClassMember :: a -> b

examples/docs/src/DuplicateNames.pursnew file+9

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

1+module DuplicateNames

2+ ( module DuplicateNames

3+ , module Prelude

4+ ) where

6+import Prelude (Unit)

8+unit :: Int

9+unit = 0

examples/docs/src/Example.pursnew file+7

@@ -0,0 +1,7 @@

1+module Example

2+ ( module Prelude

3+ , module Example2

4+ ) where

6+import Prelude (Unit())

7+import Example2 (one)

examples/docs/src/Example2.pursnew file+7

@@ -0,0 +1,7 @@

1+module Example2 where

3+one :: Int

4+one = 1

6+two :: Int

7+two = 2

examples/docs/src/MultiVirtual.pursnew file+27

@@ -0,0 +1,27 @@

1+module MultiVirtual

2+ ( module X )

3+ where

5+import MultiVirtual1 as X

6+import MultiVirtual2 as X

9+module MultiVirtual1 where

10+

11+foo :: Int

12+foo = 1

13+

14+module MultiVirtual2

15+ ( module MultiVirtual2

16+ , module MultiVirtual3

17+ ) where

18+

19+import MultiVirtual3

20+

21+bar :: Int

22+bar = 2

23+

24+module MultiVirtual3 where

25+

26+baz :: Int

27+baz = 3

examples/docs/src/NewOperators.pursnew file+12

@@ -0,0 +1,12 @@

1+module NewOperators

2+ ( module NewOperators2 )

3+ where

5+import NewOperators2

7+module NewOperators2 where

9+infixl 8 _compose as >>>

10+

11+_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c)

12+_compose f g x = f (g x)

examples/docs/src/NotAllCtors.pursnew file+5

@@ -0,0 +1,5 @@

1+module NotAllCtors

2+ ( module Prelude )

3+ where

5+import Prelude (Boolean2(True))

examples/docs/src/OldOperators.pursnew file+10

@@ -0,0 +1,10 @@

2+-- Remove this after 0.9.

3+module OldOperators (module OldOperators2) where

5+import OldOperators2

7+module OldOperators2 where

9+(>>) :: forall a. a -> a -> a

10+(>>) a b = b

examples/docs/src/ReExportedTypeClass.pursnew file+5

@@ -0,0 +1,5 @@

1+module ReExportedTypeClass

2+ ( module SomeTypeClass )

3+ where

5+import SomeTypeClass

examples/docs/src/SolitaryTypeClassMember.pursnew file+6

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

1+module SolitaryTypeClassMember

2+ ( module SomeTypeClass )

3+ where

5+import SomeTypeClass (member)

examples/docs/src/SomeTypeClass.pursnew file+5

@@ -0,0 +1,5 @@

2+module SomeTypeClass where

4+class SomeClass a where

5+ member :: a

examples/docs/src/Transitive1.pursnew file+5

@@ -0,0 +1,5 @@

1+module Transitive1

2+ ( module Transitive2 )

3+ where

5+import Transitive2

examples/docs/src/Transitive2.pursnew file+5

@@ -0,0 +1,5 @@

1+module Transitive2

2+ ( module Transitive3 )

3+ where

5+import Transitive3

examples/docs/src/Transitive3.pursnew file+4

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

1+module Transitive3 where

3+transitive3 :: Int

4+transitive3 = 0

examples/docs/src/TypeClassWithoutMembers.pursnew file+11

@@ -0,0 +1,11 @@

1+module TypeClassWithoutMembers

2+ ( module Intermediate )

3+ where

5+import Intermediate

7+module Intermediate

8+ ( module SomeTypeClass )

9+ where

10+

11+import SomeTypeClass (SomeClass)

examples/docs/src/UTF8.pursnew file+7

@@ -0,0 +1,7 @@

1+module UTF8 where

3+import Prelude (Unit, unit)

5+-- | üÜäÄ 😰

6+thing :: Unit

7+thing = unit

examples/docs/src/Virtual.pursnew file+5

@@ -0,0 +1,5 @@

1+module Virtual

2+ ( module VirtualPrelude )

3+ where

5+import Prelude as VirtualPrelude

examples/failing/1733.pursnew file+13

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

1+-- @shouldFailWith UnknownValue

3+module Main where

5+import Thingy as Thing

7+main = Thing.doesntExist "hi"

9+module Thingy where

10+

11+foo :: Int

12+foo = 1

13+

examples/failing/1825.pursnew file+9

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

1+-- @shouldFailWith UnknownValue

3+module Main where

5+data W = X | Y | Z

7+bad X a = a

8+bad Y _ = a

9+bad Z a = a

examples/passing/OperatorAliasElsewhere.pursnew file+14

@@ -0,0 +1,14 @@

1+module Def where

3+what :: forall a b. a -> b -> a

4+what a _ = a

6+module Main where

8+import Prelude

9+import Def (what)

10+import Control.Monad.Eff.Console

11+

12+infixl 4 what as ?!

13+

14+main = log $ "Done" ?! true

hierarchy/Main.hs+2−1

@@ -14,6 +14,7 @@

1414-----------------------------------------------------------------------------

1515

1616{-# LANGUAGE TupleSections #-}

17+{-# LANGUAGE DataKinds #-}

1718

1819module Main where

1920

@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions

3839 , hierarchyOutput :: Maybe FilePath

3940 }

4041

41−newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }

42+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }

4243 deriving Eq

4344

4445instance Show SuperMap where

psc-docs/Main.hs+47−39

@@ -16,6 +16,7 @@

1616module Main where

1717

1818import Control.Applicative

19+import Control.Monad.Trans.Except (runExceptT)

1920import Control.Arrow (first, second)

2021import Control.Category ((>>>))

2122import Control.Monad.Writer

@@ -68,61 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

6869 Etags -> dumpTags input dumpEtags

6970 Ctags -> dumpTags input dumpCtags

7071 Markdown -> do

71− e <- D.parseAndDesugar input [] (\_ ms -> return ms)

72− case e of

73− Left (D.ParseError err) -> do

74− hPutStrLn stderr $ show err

75− exitFailure

76− Left (D.SortModulesError err) -> do

77− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

78− exitFailure

79− Left (D.DesugarError err) -> do

80− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

81− exitFailure

82− Right ms' ->

83− case output of

84− EverythingToStdOut ->

85− putStrLn (D.renderModulesAsMarkdown ms')

86− ToStdOut names -> do

87− let (ms, missing) = takeModulesByName ms' names

88− guardMissing missing

89− putStrLn (D.renderModulesAsMarkdown ms)

90− ToFiles names -> do

91− let (ms, missing) = takeModulesByName' ms' names

92− guardMissing missing

93− let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms

94− forM_ ms'' $ \grp -> do

95− let fp = fst (head grp)

96− createDirectoryIfMissing True (takeDirectory fp)

97− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)

72+ ms <- runExceptT (D.parseAndDesugar input []

73+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))

74+ >>= successOrExit

75+

76+ case output of

77+ EverythingToStdOut ->

78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))

79+ ToStdOut names -> do

80+ let (ms', missing) = takeByName ms (map P.runModuleName names)

81+ guardMissing missing

82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))

83+ ToFiles names -> do

84+ let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)

85+ guardMissing missing

86+

87+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'

88+ forM_ ms'' $ \grp -> do

89+ let fp = fst (head grp)

90+ createDirectoryIfMissing True (takeDirectory fp)

91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))

92+

9893 where

9994 guardMissing [] = return ()

10095 guardMissing [mn] = do

101− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")

96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")

10297 exitFailure

10398 guardMissing mns = do

10499 hPutStrLn stderr "psc-docs: error: unknown modules:"

105100 forM_ mns $ \mn ->

106− hPutStrLn stderr (" * " ++ show mn)

101+ hPutStrLn stderr (" * " ++ mn)

107102 exitFailure

108103

104+ successOrExit :: Either P.MultipleErrors a -> IO a

105+ successOrExit act =

106+ case act of

107+ Right x ->

108+ return x

109+ Left err -> do

110+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

111+ exitFailure

112+

113+ takeByName = takeModulesByName D.modName

114+ takeByName' = takeModulesByName' D.modName

115+

109116-- |

110117-- Given a list of module names and a list of modules, return a list of modules

111118-- whose names appeared in the given name list, together with a list of names

112119-- for which no module could be found in the module list.

113120--

114−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])

115−takeModulesByName modules names =

116− first (map fst) (takeModulesByName' modules (map (,()) names))

121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])

122+takeModulesByName getModuleName modules names =

123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))

117124

118125-- |

119−-- Like takeModulesByName but also keeps some extra data with the module.

126+-- Like takeModulesByName, but also keeps some extra information with each

127+-- module.

120128--

121−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])

122−takeModulesByName' modules = foldl go ([], [])

129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])

130+takeModulesByName' getModuleName modules = foldl go ([], [])

123131 where

124132 go (ms, missing) (name, x) =

125− case find ((== name) . P.getModuleName) modules of

133+ case find ((== name) . getModuleName) modules of

126134 Just m -> ((m, x) : ms, missing)

127135 Nothing -> (ms, name : missing)

128136

@@ -236,16 +244,16 @@ examples =

236244 PP.vcat $ map PP.text

237245 [ "Examples:"

238246 , " print documentation for Data.List to stdout:"

239− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

247+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

240248 , " --docgen Data.List"

241249 , ""

242250 , " write documentation for Data.List to docs/Data.List.md:"

243− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

251+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

244252 , " --docgen Data.List:docs/Data.List.md"

245253 , ""

246254 , " write documentation for Data.List to docs/Data.List.md, and"

247255 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"

248− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"

256+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

249257 , " --docgen Data.List:docs/Data.List.md \\"

250258 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

251259 ]

psc/JSON.hs+12−1

@@ -30,12 +30,16 @@ data ErrorPosition = ErrorPosition

3030 , endColumn :: Int

3131 }

3232

33+data ErrorSuggestion = ErrorSuggestion { replacement :: String }

34+

3335data JSONError = JSONError

3436 { position :: Maybe ErrorPosition

3537 , message :: String

3638 , errorCode :: String

39+ , errorLink :: String

3740 , filename :: Maybe String

3841 , moduleName :: Maybe String

42+ , suggestion :: Maybe ErrorSuggestion

3943 }

4044

4145data JSONResult = JSONResult

@@ -46,6 +50,8 @@ data JSONResult = JSONResult

4650$(A.deriveJSON A.defaultOptions ''ErrorPosition)

4751$(A.deriveJSON A.defaultOptions ''JSONError)

4852$(A.deriveJSON A.defaultOptions ''JSONResult)

53+$(A.deriveJSON A.defaultOptions ''ErrorSuggestion)

54+

4955

5056toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]

5157toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors

@@ -53,10 +59,12 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro

5359toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError

5460toJSONError verbose level e =

5561 JSONError (toErrorPosition <$> sspan)

56− (P.renderBox (P.prettyPrintSingleError verbose level (P.stripModuleAndSpan e)))

62+ (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))

5763 (P.errorCode e)

64+ (P.wikiUri e)

5865 (P.spanName <$> sspan)

5966 (P.runModuleName <$> P.errorModule e)

67+ (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))

6068 where

6169 sspan :: Maybe P.SourceSpan

6270 sspan = P.errorSpan e

@@ -67,3 +75,6 @@ toJSONError verbose level e =

6775 (P.sourcePosColumn (P.spanStart ss))

6876 (P.sourcePosLine (P.spanEnd ss))

6977 (P.sourcePosColumn (P.spanEnd ss))

78+ toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion

79+-- TODO: Adding a newline because source spans chomp everything up to the next character

80+ toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n"

psc/Main.hs+3−3

@@ -76,13 +76,13 @@ printWarningsAndErrors verbose True warnings errors = do

7676

7777compile :: PSCMakeOptions -> IO ()

7878compile PSCMakeOptions{..} = do

79− input <- globWarningOnMisses warnFileTypeNotFound pscmInput

80− when (null input) $ do

79+ input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput

80+ when (null input && not pscmJSONErrors) $ do

8181 hPutStrLn stderr "psc: No input files."

8282 exitFailure

8383 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input

8484 moduleFiles <- readInput (InputOptions pursFiles)

85− inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput

85+ inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput

8686 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)

8787 (makeErrors, makeWarnings) <- runMake pscmOpts $ do

8888 (ms, foreigns) <- parseInputs moduleFiles foreignFiles

psci/Completion.hs+6−4

@@ -1,3 +1,5 @@

1+{-# LANGUAGE DataKinds #-}

13module Completion where

35import Prelude ()

@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf

184186nubOnFst :: Eq a => [(a, b)] -> [(a, b)]

185187nubOnFst = nubBy ((==) `on` fst)

186188

187−typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]

189+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]

188190typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations

189191 where

190− getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)

192+ getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)

191193 getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)

192194 getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)

193195 getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d

@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations

204206 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d

205207 getDeclNames _ = []

206208

207−dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]

209+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

208210dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

209211 where

210− go :: P.Declaration -> [(N.ProperName, P.Declaration)]

212+ go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

211213 go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)

212214 go (P.PositionedDeclaration _ _ d) = go d

213215 go _ = []

psci/PSCi.hs+20−10

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

22{-# LANGUAGE GeneralizedNewtypeDeriving #-}

33{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TupleSections #-}

5+{-# LANGUAGE DataKinds #-}

67-- |

78-- PureScript Compiler Interactive.

@@ -326,7 +327,7 @@ handleShowImportedModules = do

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

327328 showRef (P.ValueRef ident) = N.runIdent ident

328329 showRef (P.TypeClassRef pn) = N.runProperName pn

329− showRef (P.ProperRef pn) = N.runProperName pn

330+ showRef (P.ProperRef pn) = pn

330331 showRef (P.TypeInstanceRef ident) = N.runIdent ident

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

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

@@ -391,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) =

391392 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

392393 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

393394

394− findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

395+ findTypeClass

396+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

397+ -> P.Qualified (P.ProperName 'P.ClassName)

398+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

395399 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

396400

397− showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box

401+ showTypeClass

402+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

403+ -> Maybe Box.Box

398404 showTypeClass (_, Nothing) = Nothing

399405 showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

400406 let constraints =

@@ -418,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) =

418424 Box.// Box.moveRight 2 classBody

419425

420426

421− findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

427+ findType

428+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

429+ -> P.Qualified (P.ProperName 'P.TypeName)

430+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

422431 findType envTypes name = (name, M.lookup name envTypes)

423432

424− showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

425− -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])

426− -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)

427− -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

428− -> Maybe Box.Box

433+ showType

434+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

435+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

436+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

437+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

438+ -> Maybe Box.Box

429439 showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

430440 case (typ, M.lookup n typeSynonymsEnv) of

431441 (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

432− if M.member n typeClassesEnv

442+ if M.member (fmap P.coerceProperName n) typeClassesEnv

433443 then

434444 Nothing

435445 else

psci/Types.hs+2−2

@@ -51,11 +51,11 @@ mkPSCiState :: [ImportedModule]

5151 -> [P.Declaration]

5252 -> [String]

5353 -> PSCiState

54−mkPSCiState imported loaded foreign lets nodeFlags =

54+mkPSCiState imported loaded foreigns lets nodeFlags =

5555 (initialPSCiState

5656 |> each imported updateImportedModules

5757 |> updateModules loaded)

58− { psciForeignFiles = foreign

58+ { psciForeignFiles = foreigns

5959 , psciLetBindings = lets

6060 , psciNodeFlags = nodeFlags

6161 }

purescript.cabal+10−1

@@ -20,6 +20,9 @@ tested-with: GHC==7.8

2020

2121extra-source-files: examples/passing/*.purs

2222 , examples/failing/*.purs

23+ , examples/docs/bower_components/purescript-prelude/src/*.purs

24+ , examples/docs/bower.json

25+ , examples/docs/src/*.purs

2326 , tests/support/setup.js

2427 , tests/support/package.json

2528 , tests/support/bower.json

@@ -175,6 +178,8 @@ library

175178

176179 Language.PureScript.Docs

177180 Language.PureScript.Docs.Convert

181+ Language.PureScript.Docs.Convert.Single

182+ Language.PureScript.Docs.Convert.ReExports

178183 Language.PureScript.Docs.Render

179184 Language.PureScript.Docs.Types

180185 Language.PureScript.Docs.RenderedCode

@@ -194,6 +199,8 @@ library

194199 Control.Monad.Supply.Class

195200

196201 System.IO.UTF8

202+

203+ extensions: DataKinds

197204 exposed: True

198205 buildable: True

199206 hs-source-dirs: src

@@ -234,7 +241,8 @@ executable psc-docs

234241 build-depends: base >=4 && <5, purescript -any,

235242 optparse-applicative >= 0.10.0, process -any, mtl -any,

236243 split -any, ansi-wl-pprint -any, directory -any,

237− filepath -any, Glob -any

244+ filepath -any, Glob -any, transformers -any,

245+ transformers-compat -any

238246 main-is: Main.hs

239247 buildable: True

240248 hs-source-dirs: psc-docs

@@ -298,6 +306,7 @@ test-suite tests

298306 main-is: Main.hs

299307 other-modules: TestsSetup

300308 TestPscPublish

309+ TestDocs

301310 buildable: True

302311 hs-source-dirs: tests tests/common

303312

src/Control/Monad/Logger.hs+1−1

@@ -30,7 +30,7 @@ import Control.Monad.Base (MonadBase(..))

3030import Control.Monad.Trans.Control (MonadBaseControl(..))

3131

3232-- | A replacement for WriterT IO which uses mutable references.

33−data Logger w a = Logger { runLogger :: IORef w -> IO a }

33+newtype Logger w a = Logger { runLogger :: IORef w -> IO a }

3434

3535-- | Run a Logger computation, starting with an empty log.

3636runLogger' :: (Monoid w) => Logger w a -> IO (a, w)

src/Language/PureScript.hs−1

@@ -13,7 +13,6 @@

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE DataKinds #-}

1716{-# LANGUAGE FlexibleContexts #-}

1817{-# LANGUAGE ScopedTypeVariables #-}

1918

src/Language/PureScript/AST/Binders.hs+5−19

@@ -1,23 +1,8 @@

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

2−--

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

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Case binders

1+-- |

2+-- Case binders

123--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

16−

174module Language.PureScript.AST.Binders where

185

19−import qualified Data.Data as D

20−

216import Language.PureScript.AST.SourcePos

227import Language.PureScript.Names

238import Language.PureScript.Comments

@@ -54,7 +39,7 @@ data Binder

5439 -- |

5540 -- A binder which matches a data constructor

5641 --

57− | ConstructorBinder (Qualified ProperName) [Binder]

42+ | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]

5843 -- |

5944 -- A binder which matches a record and binds its properties

6045 --

@@ -74,7 +59,8 @@ data Binder

7459 -- |

7560 -- A binder with a type annotation

7661 --

77− | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)

62+ | TypedBinder Type Binder

63+ deriving (Show, Read, Eq)

7864

7965-- |

8066-- Collect all names introduced in binders in an expression

src/Language/PureScript/AST/Declarations.hs+30−25

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

1−{-# LANGUAGE DeriveDataTypeable #-}

21{-# LANGUAGE ScopedTypeVariables #-}

32{-# LANGUAGE TemplateHaskell #-}

43{-# LANGUAGE LambdaCase #-}

@@ -15,7 +14,6 @@ import Data.Aeson.TH

1514import Data.List (nub, (\\))

1615import Data.Maybe (mapMaybe)

1716

18−import qualified Data.Data as D

1917import qualified Data.Map as M

2018

2119import Control.Monad.Identity

@@ -35,7 +33,8 @@ import Language.PureScript.Environment

3533-- a list of declarations, and a list of the declarations that are

3634-- explicitly exported. If the export list is Nothing, everything is exported.

3735--

38−data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)

36+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])

37+ deriving (Show, Read)

3938

4039-- | Return a module's name.

4140getModuleName :: Module -> ModuleName

@@ -60,7 +59,7 @@ data DeclarationRef

6059 -- |

6160 -- A type constructor with data constructors

6261 --

63− = TypeRef ProperName (Maybe [ProperName])

62+ = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])

6463 -- |

6564 -- A value

6665 --

@@ -68,7 +67,7 @@ data DeclarationRef

6867 -- |

6968 -- A type class

7069 --

71− | TypeClassRef ProperName

70+ | TypeClassRef (ProperName 'ClassName)

7271 -- |

7372 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

7473 --

@@ -80,12 +79,12 @@ data DeclarationRef

8079 -- |

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

8281 -- or TypeRef during name desugaring.

83− | ProperRef ProperName

82+ | ProperRef String

8483 -- |

8584 -- A declaration reference with source position information

8685 --

8786 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

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

87+ deriving (Show, Read)

8988

9089instance Eq DeclarationRef where

9190 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

@@ -108,7 +107,7 @@ isModuleRef _ = False

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

109108-- list of duplicate data constructors.

110109--

111−findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])

110+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])

112111findDuplicateRefs refs =

113112 let positionless = stripPosInfo `map` refs

114113 simplified = simplifyTypeRefs `map` positionless

@@ -141,12 +140,16 @@ data ImportDeclarationType

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

142141 --

143142 | Hiding [DeclarationRef]

144− deriving (Eq, Show, Read, D.Data, D.Typeable)

143+ deriving (Eq, Show, Read)

145144

146145isImplicit :: ImportDeclarationType -> Bool

147146isImplicit Implicit = True

148147isImplicit _ = False

149148

149+isExplicit :: ImportDeclarationType -> Bool

150+isExplicit (Explicit _) = True

151+isExplicit _ = False

152+

150153-- |

151154-- The data type of declarations

152155--

@@ -154,7 +157,7 @@ data Declaration

154157 -- |

155158 -- A data type declaration (data or newtype, name, arguments, data constructors)

156159 --

157− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

160+ = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

158161 -- |

159162 -- A minimal mutually recursive set of data type declarations

160163 --

@@ -162,7 +165,7 @@ data Declaration

162165 -- |

163166 -- A type synonym declaration (name, arguments, type)

164167 --

165− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

168+ | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type

166169 -- |

167170 -- A type declaration for a value (name, ty)

168171 --

@@ -182,11 +185,11 @@ data Declaration

182185 -- |

183186 -- A data type foreign import (name, kind)

184187 --

185− | ExternDataDeclaration ProperName Kind

188+ | ExternDataDeclaration (ProperName 'TypeName) Kind

186189 -- |

187190 -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

188191 --

189− | FixityDeclaration Fixity String (Maybe Ident)

192+ | FixityDeclaration Fixity String (Maybe (Qualified Ident))

190193 -- |

191194 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

192195 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

@@ -195,17 +198,17 @@ data Declaration

195198 -- |

196199 -- A type class declaration (name, argument, implies, member declarations)

197200 --

198− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]

201+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]

199202 -- |

200203 -- A type instance declaration (name, dependencies, class name, instance types, member

201204 -- declarations)

202205 --

203− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody

206+ | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody

204207 -- |

205208 -- A declaration with source position information

206209 --

207210 | PositionedDeclaration SourceSpan [Comment] Declaration

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

211+ deriving (Show, Read)

209212

210213-- | The members of a type class instance declaration

211214data TypeInstanceBody

@@ -213,7 +216,7 @@ data TypeInstanceBody

213216 = DerivedInstance

214217 -- | This is a regular (explicit) instance

215218 | ExplicitInstance [Declaration]

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

219+ deriving (Show, Read)

217220

218221mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

219222mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

@@ -390,7 +393,7 @@ data Expr

390393 -- |

391394 -- A data constructor

392395 --

393− | Constructor (Qualified ProperName)

396+ | Constructor (Qualified (ProperName 'ConstructorName))

394397 -- |

395398 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

396399 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

@@ -412,7 +415,7 @@ data Expr

412415 -- An application of a typeclass dictionary constructor. The value should be

413416 -- an ObjectLiteral.

414417 --

415− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

418+ | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr

416419 -- |

417420 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

418421 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

@@ -420,19 +423,20 @@ data Expr

420423 -- at superclass implementations when searching for a dictionary, the type class name and

421424 -- instance type, and the type class dictionaries in scope.

422425 --

423− | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

426+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

424427 -- |

425428 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

426429 --

427− | TypeClassDictionaryAccessor (Qualified ProperName) Ident

430+ | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident

428431 -- |

429432 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

430433 --

431− | SuperClassDictionary (Qualified ProperName) [Type]

434+ | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

432435 -- |

433436 -- A value with source position information

434437 --

435− | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)

438+ | PositionedValue SourceSpan [Comment] Expr

439+ deriving (Show, Read)

436440

437441-- |

438442-- An alternative in a case statement

@@ -446,7 +450,7 @@ data CaseAlternative = CaseAlternative

446450 -- The result expression or a collect of guarded expressions

447451 --

448452 , caseAlternativeResult :: Either [(Guard, Expr)] Expr

449− } deriving (Show, Read, D.Data, D.Typeable)

453+ } deriving (Show, Read)

450454

451455-- |

452456-- A statement in a do-notation block

@@ -467,7 +471,8 @@ data DoNotationElement

467471 -- |

468472 -- A do notation element with source position information

469473 --

470− | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)

474+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

475+ deriving (Show, Read)

471476

472477$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

473478$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

src/Language/PureScript/AST/Exported.hs+36−21

@@ -1,8 +1,7 @@

1−

2−module Language.PureScript.AST.Exported (

3− exportedDeclarations,

4− isExported

5−) where

1+module Language.PureScript.AST.Exported

2+ ( exportedDeclarations

3+ , isExported

4+ ) where

76import Control.Category ((>>>))

87import Data.Maybe (mapMaybe)

@@ -23,12 +22,12 @@ import Language.PureScript.Names

2322-- instances will be incorrectly removed in some cases.

2423--

2524exportedDeclarations :: Module -> [Declaration]

26−exportedDeclarations (Module _ _ _ decls exps) = go decls

25+exportedDeclarations (Module _ _ mn decls exps) = go decls

2726 where

2827 go = flattenDecls

2928 >>> filter (isExported exps)

3029 >>> map (filterDataConstructors exps)

31− >>> filterInstances exps

30+ >>> filterInstances mn exps

3231

3332-- |

3433-- Filter out all data constructors from a declaration which are not exported.

@@ -52,10 +51,15 @@ filterDataConstructors _ other = other

5251-- produce incorrect results if this is not the case - for example, type class

5352-- instances will be incorrectly removed in some cases.

5453--

55−filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]

56−filterInstances Nothing = id

57−filterInstances (Just exps) =

58− let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps

54+filterInstances

55+ :: ModuleName

56+ -> Maybe [DeclarationRef]

57+ -> [Declaration]

58+ -> [Declaration]

59+filterInstances _ Nothing = id

60+filterInstances mn (Just exps) =

61+ let refs = Left `map` mapMaybe typeClassName exps

62+ ++ Right `map` mapMaybe typeName exps

5963 in filter (all (visibleOutside refs) . typeInstanceConstituents)

6064 where

6165 -- Given a Qualified ProperName, and a list of all exported types and type

@@ -65,13 +69,24 @@ filterInstances (Just exps) =

6569 -- * the name is defined in the same module and is exported,

6670 -- * the name is defined in a different module (and must be exported from

6771 -- that module; the code would fail to compile otherwise).

68− visibleOutside _ (Qualified (Just _) _) = True

69− visibleOutside refs (Qualified Nothing n) = n `elem` refs

70−

72+ visibleOutside

73+ :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]

74+ -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))

75+ -> Bool

76+ visibleOutside refs q

77+ | either checkQual checkQual q = True

78+ | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs

79+

80+ -- Check that a qualified name is qualified for a different module

81+ checkQual :: Qualified a -> Bool

82+ checkQual q = isQualified q && not (isQualifiedWith mn q)

83+

84+ typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)

7185 typeName (TypeRef n _) = Just n

7286 typeName (PositionedDeclarationRef _ _ r) = typeName r

7387 typeName _ = Nothing

7488

89+ typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)

7590 typeClassName (TypeClassRef n) = Just n

7691 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

7792 typeClassName _ = Nothing

@@ -79,17 +94,17 @@ filterInstances (Just exps) =

7994-- |

8095-- Get all type and type class names referenced by a type instance declaration.

8196--

82−typeInstanceConstituents :: Declaration -> [Qualified ProperName]

97+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]

8398typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

84− className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

99+ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

85100 where

86101

87− fromConstraint (name, tys') = name : concatMap fromType tys'

102+ fromConstraint (name, tys') = Left name : concatMap fromType tys'

88103 fromType = everythingOnTypes (++) go

89104

90105 -- Note that type synonyms are disallowed in instance declarations, so

91106 -- we don't need to handle them here.

92− go (TypeConstructor n) = [n]

107+ go (TypeConstructor n) = [Right n]

93108 go (ConstrainedType cs _) = concatMap fromConstraint cs

94109 go _ = []

95110

@@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps

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

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

120135

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

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

136+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'

137+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'

123138

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

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

@@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps

129144-- Test if a data constructor for a given type is exported, given a module's

130145-- export list. Prefer 'exportedDeclarations' to this function, where possible.

131146--

132−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool

147+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool

133148isDctorExported _ Nothing _ = True

134149isDctorExported ident (Just exps) ctor = test `any` exps

135150 where

src/Language/PureScript/AST/Operators.hs+7−18

@@ -1,23 +1,10 @@

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

2−--

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

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Operators fixity and associativity

12−--

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

14−

151{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE DeriveDataTypeable #-}

172

3+-- |

4+-- Operators fixity and associativity

5+--

186module Language.PureScript.AST.Operators where

197

20−import qualified Data.Data as D

218import Data.Aeson ((.=))

229import qualified Data.Aeson as A

2310

@@ -31,7 +18,8 @@ type Precedence = Integer

3118-- |

3219-- Associativity for infix operators

3320--

34−data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

21+data Associativity = Infixl | Infixr | Infix

22+ deriving (Show, Read, Eq, Ord)

3523

3624showAssoc :: Associativity -> String

3725showAssoc Infixl = "infixl"

@@ -53,7 +41,8 @@ instance A.FromJSON Associativity where

5341-- |

5442-- Fixity data for infix operators

5543--

56−data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

44+data Fixity = Fixity Associativity Precedence

45+ deriving (Show, Read, Eq, Ord)

5746

5847instance A.ToJSON Fixity where

5948 toJSON (Fixity associativity precedence) =

src/Language/PureScript/AST/SourcePos.hs+5−18

@@ -1,28 +1,15 @@

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

2−--

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

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Source position information

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE ScopedTypeVariables #-}

172{-# LANGUAGE RecordWildCards #-}

183{-# LANGUAGE OverloadedStrings #-}

194

5+-- |

6+-- Source position information

7+--

208module Language.PureScript.AST.SourcePos where

219

2210import Prelude ()

2311import Prelude.Compat

2412

25−import qualified Data.Data as D

2613import Data.Aeson ((.=), (.:))

2714import qualified Data.Aeson as A

2815

@@ -38,7 +25,7 @@ data SourcePos = SourcePos

3825 -- Column number

3926 --

4027 , sourcePosColumn :: Int

41− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

28+ } deriving (Show, Read, Eq, Ord)

4229

4330displaySourcePos :: SourcePos -> String

4431displaySourcePos sp =

@@ -66,7 +53,7 @@ data SourceSpan = SourceSpan

6653 -- End of the span

6754 --

6855 , spanEnd :: SourcePos

69− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

56+ } deriving (Show, Read, Eq, Ord)

7057

7158displayStartEndPos :: SourceSpan -> String

7259displayStartEndPos sp =

src/Language/PureScript/Bundle.hs+14−11

@@ -95,7 +95,7 @@ data ExportType

9595-- Each is labelled with the original AST node which generated it, so that we can dump it back

9696-- into the output during codegen.

9797data ModuleElement

98− = Require JSNode String ModuleIdentifier

98+ = Require JSNode String (Either String ModuleIdentifier)

9999 | Member JSNode Bool String [JSNode] [Key]

100100 | ExportsList [(ExportType, String, JSNode, [Key])]

101101 | Other JSNode

@@ -137,13 +137,13 @@ node (NN n) = n

137137node (NT n _ _) = n

138138

139139-- | Calculate the ModuleIdentifier which a require(...) statement imports.

140−checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier

140+checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier

141141checkImportPath _ "./foreign" m _ =

142− Just (ModuleIdentifier (moduleName m) Foreign)

142+ Right (ModuleIdentifier (moduleName m) Foreign)

143143checkImportPath requirePath name _ names

144144 | Just name' <- stripPrefix (fromMaybe "" requirePath) name

145− , name' `S.member` names = Just (ModuleIdentifier name' Regular)

146−checkImportPath _ _ _ _ = Nothing

145+ , name' `S.member` names = Right (ModuleIdentifier name' Regular)

146+checkImportPath _ name _ _ = Left name

147147

148148-- | Compute the dependencies of all elements in a module, and add them to the tree.

149149--

@@ -166,7 +166,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)

166166 imports = mapMaybe toImport es

167167 where

168168 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)

169− toImport (Require _ nm mid) = Just (nm, mid)

169+ toImport (Require _ nm (Right mid)) = Just (nm, mid)

170170 toImport _ = Nothing

171171

172172 -- | Collects all member names in scope, so that we can identify dependencies of the second type.

@@ -226,7 +226,7 @@ toModule requirePath mids mid top

226226 , JSIdentifier "require" <- node req

227227 , JSArguments _ [ impS ] _ <- node impP

228228 , JSStringLiteral _ importPath <- node impS

229− , Just importPath' <- checkImportPath requirePath importPath mid mids

229+ , importPath' <- checkImportPath requirePath importPath mid mids

230230 = pure (Require n importName importPath')

231231 toModuleElement n

232232 | JSVariables var [ varIntro ] _ <- node n

@@ -371,7 +371,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top

371371 return (m, mid, mapMaybe getKey els)

372372

373373 getKey :: ModuleElement -> Maybe ModuleIdentifier

374− getKey (Require _ _ mi) = Just mi

374+ getKey (Require _ _ (Right mi)) = Just mi

375375 getKey _ = Nothing

376376

377377-- | A module is empty if it contains no exported members (in other words,

@@ -416,9 +416,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

416416 declToJS (Require _ nm req) =

417417 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])

418418 [ NN (JSVarDecl (sp (JSIdentifier nm))

419− [ sp (JSLiteral "=")

420− , moduleReference sp (moduleName req)

421− ])

419+ (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))

422420 ]

423421 (nt (JSLiteral ";"))) ]

424422 declToJS (ExportsList exps) = map toExport exps

@@ -467,6 +465,11 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

467465 , lf

468466 ]

469467

468+ require :: String -> [JSNode]

469+ require mn = [ sp (JSIdentifier "require")

470+ , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))

471+ ]

472+

470473 moduleReference :: (Node -> JSNode) -> String -> JSNode

471474 moduleReference f mn =

472475 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]

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

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

9090 go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

9191 go acc used (mn' : mns') =

9292 let mni = Ident $ runModuleName mn'

93− in if mni `elem` used

93+ in if mn' /= mn && mni `elem` used

9494 then let newName = freshModuleName 1 mn' used

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

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

src/Language/PureScript/CodeGen/JS/AST.hs+6−18

@@ -1,27 +1,12 @@

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

2−--

3−-- Module : Language.PureScript.CodeGen.JS.AST

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

111-- |

122-- Data types for the intermediate simplified-Javascript AST

133--

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

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

17−

184module Language.PureScript.CodeGen.JS.AST where

195

206import Prelude ()

217import Prelude.Compat

228

239import Control.Monad.Identity

24−import Data.Data

2510

2611import Language.PureScript.Comments

2712import Language.PureScript.Traversals

@@ -49,7 +34,8 @@ data UnaryOperator

4934 -- |

5035 -- Constructor

5136 --

52− | JSNew deriving (Show, Read, Eq, Data, Typeable)

37+ | JSNew

38+ deriving (Show, Read, Eq)

5339

5440-- |

5541-- Built-in binary operators

@@ -130,7 +116,8 @@ data BinaryOperator

130116 -- |

131117 -- Bitwise right shift with zero-fill

132118 --

133− | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)

119+ | ZeroFillShiftRight

120+ deriving (Show, Read, Eq)

134121

135122-- |

136123-- Data type for simplified Javascript expressions

@@ -251,7 +238,8 @@ data JS

251238 -- |

252239 -- Commented Javascript

253240 --

254− | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)

241+ | JSComment [Comment] JS

242+ deriving (Show, Read, Eq)

255243

256244--

257245-- Traversals

src/Language/PureScript/Comments.hs+3−17

@@ -1,29 +1,15 @@

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

2−--

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

4−-- Copyright : (c) Phil Freeman 2015

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE TemplateHaskell #-}

113-- |

124-- Defines the types of source code comments

135--

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

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

17−{-# LANGUAGE TemplateHaskell #-}

18−

196module Language.PureScript.Comments where

207

218import Data.Aeson.TH

22−import qualified Data.Data as D

239

2410data Comment

2511 = LineComment String

2612 | BlockComment String

27− deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

13+ deriving (Show, Read, Eq, Ord)

2814

2915$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

src/Language/PureScript/CoreFn/Binders.hs+7−20

@@ -1,24 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.CoreFn.Binders

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation for binders

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE DeriveFunctor #-}

172

3+-- |

4+-- The core functional representation for binders

5+--

186module Language.PureScript.CoreFn.Binders where

197

20−import qualified Data.Data as D

21−

228import Language.PureScript.CoreFn.Literals

239import Language.PureScript.Names

2410

@@ -39,10 +25,11 @@ data Binder a

3925 --

4026 | VarBinder a Ident

4127 -- |

42− -- A binder which matches a data constructor (type name, constructor name, binders)

28+ -- A binder which matches a data constructor

4329 --

44− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]

30+ | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]

4531 -- |

4632 -- A binder which binds its input to an identifier

4733 --

48− | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor)

34+ | NamedBinder a Ident (Binder a)

35+ deriving (Show, Read, Functor)

src/Language/PureScript/CoreFn/Desugar.hs+12−6

@@ -55,8 +55,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

5555 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

5656 [NonRec name (exprToCoreFn ss com Nothing e)]

5757 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58− let qname = Qualified (Just mn) alias

59− in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]

58+ [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]

6059 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

6160 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

6261 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

@@ -171,7 +170,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

171170 -- |

172171 -- Gets metadata for data constructors.

173172 --

174− getConstructorMeta :: Qualified ProperName -> Meta

173+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta

175174 getConstructorMeta ctor =

176175 case lookupConstructor env ctor of

177176 (Newtype, _, _, _) -> IsNewtype

@@ -179,9 +178,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

179178 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

180179 in IsConstructor constructorType fields

181180 where

182− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int

181+

182+ numConstructors

183+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

184+ -> Int

183185 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

184− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

186+

187+ typeConstructor

188+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

189+ -> (ModuleName, ProperName 'TypeName)

185190 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

186191 typeConstructor _ = internalError "Invalid argument to typeConstructor"

187192

@@ -197,6 +202,7 @@ findQualModules decls =

197202 where

198203 fqDecls :: A.Declaration -> [ModuleName]

199204 fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

205+ fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

200206 fqDecls _ = []

201207

202208 fqValues :: A.Expr -> [ModuleName]

@@ -255,5 +261,5 @@ mkTypeClassConstructor ss com supers members =

255261-- |

256262-- Converts a ProperName to an Ident.

257263--

258−properToIdent :: ProperName -> Ident

264+properToIdent :: ProperName a -> Ident

259265properToIdent = Ident . runProperName

src/Language/PureScript/CoreFn/Expr.hs+10−21

@@ -1,26 +1,12 @@

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

2−--

3−-- Module : Language.PureScript.CoreFn.Expr

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE DeriveFunctor #-}

172

3+-- |

4+-- The core functional representation

5+--

186module Language.PureScript.CoreFn.Expr where

197

208import Control.Arrow ((***))

219

22−import qualified Data.Data as D

23−

2410import Language.PureScript.CoreFn.Binders

2511import Language.PureScript.CoreFn.Literals

2612import Language.PureScript.Names

@@ -36,7 +22,7 @@ data Expr a

3622 -- |

3723 -- A data constructor (type name, constructor name, field names)

3824 --

39− | Constructor a ProperName ProperName [Ident]

25+ | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]

4026 -- |

4127 -- A record property accessor

4228 --

@@ -64,7 +50,8 @@ data Expr a

6450 -- |

6551 -- A let binding

6652 --

67− | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)

53+ | Let a [Bind a] (Expr a)

54+ deriving (Show, Read, Functor)

6855

6956-- |

7057-- A let or module binding.

@@ -77,7 +64,8 @@ data Bind a

7764 -- |

7865 -- Mutually recursive binding group for several values

7966 --

80− | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)

67+ | Rec [(Ident, Expr a)]

68+ deriving (Show, Read, Functor)

8169

8270-- |

8371-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -96,7 +84,8 @@ data CaseAlternative a = CaseAlternative

9684 -- The result expression or a collect of guarded expressions

9785 --

9886 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

99− } deriving (Show, Read, D.Data, D.Typeable)

87+ }

88+ deriving (Show, Read)

10089

10190instance Functor CaseAlternative where

10291

src/Language/PureScript/CoreFn/Literals.hs+5−18

@@ -1,24 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.CoreFn.Literals

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation for literal values.

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE DeriveFunctor #-}

172

3+-- |

4+-- The core functional representation for literal values.

5+--

186module Language.PureScript.CoreFn.Literals where

197

20−import qualified Data.Data as D

21−

228-- |

239-- Data type for literal values. Parameterised so it can be used for Exprs and

2410-- Binders.

@@ -47,4 +33,5 @@ data Literal a

4733 -- |

4834 -- An object literal

4935 --

50− | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)

36+ | ObjectLiteral [(String, a)]

37+ deriving (Show, Read, Functor)

src/Language/PureScript/CoreFn/Meta.hs+6−19

@@ -1,23 +1,8 @@

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

2−--

3−-- Module : Language.PureScript.CoreFn.Meta

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Metadata annotations for core functional representation

1+-- |

2+-- Metadata annotations for core functional representation

123--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

16−

174module Language.PureScript.CoreFn.Meta where

185

19−import qualified Data.Data as D

20−

216import Language.PureScript.Names

227

238-- |

@@ -39,7 +24,8 @@ data Meta

3924 -- |

4025 -- The contained reference is for a foreign member

4126 --

42− | IsForeign deriving (Show, Read, D.Data, D.Typeable)

27+ | IsForeign

28+ deriving (Show, Read)

4329

4430-- |

4531-- Data constructor metadata

@@ -52,4 +38,5 @@ data ConstructorType

5238 -- |

5339 -- The constructor is for a type with multiple construcors

5440 --

55− | SumType deriving (Show, Read, D.Data, D.Typeable)

41+ | SumType

42+ deriving (Show, Read)

src/Language/PureScript/Docs/AsMarkdown.hs+34−16

@@ -1,10 +1,19 @@

11{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE FlexibleContexts #-}

3−module Language.PureScript.Docs.AsMarkdown (

4− renderModulesAsMarkdown

5−) where

4+module Language.PureScript.Docs.AsMarkdown

5+ ( renderModulesAsMarkdown

6+ , Docs

7+ , runDocs

8+ , modulesAsMarkdown

9+ ) where

610

7−import Control.Monad.Writer hiding (First)

11+import Prelude ()

12+import Prelude.Compat

13+

14+import Control.Monad (unless, zipWithM_)

15+import Control.Monad.Writer (Writer, tell, execWriter)

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

817import Data.Foldable (for_)

918import Data.List (partition)

1019

@@ -19,9 +28,14 @@ import qualified Language.PureScript.Docs.Render as Render

1928-- Take a list of modules and render them all in order, returning a single

2029-- Markdown-formatted String.

2130--

22−renderModulesAsMarkdown :: [P.Module] -> String

23−renderModulesAsMarkdown =

24− runDocs . modulesAsMarkdown . map Convert.convertModule

31+renderModulesAsMarkdown ::

32+ (Functor m, Applicative m,

33+ MonadError P.MultipleErrors m) =>

34+ P.Env ->

35+ [P.Module] ->

36+ m String

37+renderModulesAsMarkdown env =

38+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env

2539

2640modulesAsMarkdown :: [Module] -> Docs

2741modulesAsMarkdown = mapM_ moduleAsMarkdown

@@ -31,21 +45,27 @@ moduleAsMarkdown Module{..} = do

3145 headerLevel 2 $ "Module " ++ modName

3246 spacer

3347 for_ modComments tell'

34− mapM_ declAsMarkdown modDeclarations

48+ mapM_ (declAsMarkdown modName) modDeclarations

3549 spacer

50+ for_ modReExports $ \(mn, decls) -> do

51+ let modName' = P.runModuleName mn

52+ headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"

53+ spacer

54+ mapM_ (declAsMarkdown modName') decls

3655

37−declAsMarkdown :: Declaration -> Docs

38−declAsMarkdown decl@Declaration{..} = do

56+declAsMarkdown :: String -> Declaration -> Docs

57+declAsMarkdown mn decl@Declaration{..} = do

58+ let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }

3959 headerLevel 4 (ticks declTitle)

4060 spacer

4161

4262 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

4363 fencedBlock $ do

44− tell' (codeToString $ Render.renderDeclaration decl)

64+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)

4565 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

4666 spacer

4767

48− for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)

68+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

4969

5070 for_ declComments tell'

5171

@@ -68,11 +88,9 @@ codeToString = outputWith elemAsMarkdown

6888 elemAsMarkdown (Keyword x) = x

6989 elemAsMarkdown Space = " "

7090

71−fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) alias =

73− -- TODO: link alias name to member

91+fixityAsMarkdown :: P.Fixity -> Docs

92+fixityAsMarkdown (P.Fixity associativity precedence) =

7493 tell' $ concat [ "_"

75− , maybe "" (\i -> "alias for " ++ i ++ " - ") alias

7694 , associativityStr

7795 , " / precedence "

7896 , show precedence

src/Language/PureScript/Docs/Convert.hs+56−198

@@ -2,228 +2,86 @@

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE ViewPatterns #-}

5+{-# LANGUAGE FlexibleContexts #-}

67-- | Functions for converting PureScript ASTs into values of the data types

78-- from Language.PureScript.Docs.

910module Language.PureScript.Docs.Convert

10− ( convertModule

11+ ( convertModules

12+ , convertModulesInPackage

1113 , collectBookmarks

1214 ) where

1315

1416import Prelude ()

1517import Prelude.Compat

1618

17−import Control.Monad

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

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

1821import Control.Category ((>>>))

19−import Data.Either

20−import Data.Maybe (mapMaybe, isNothing)

21−import Data.List (nub, isPrefixOf, isSuffixOf)

22+import qualified Data.Map as Map

2223

2324import qualified Language.PureScript as P

2425

2526import Language.PureScript.Docs.Types

27+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

28+import Language.PureScript.Docs.Convert.ReExports (updateReExports)

2629

2730-- |

28−-- Convert a single Module.

31+-- Like convertModules, except that it takes a list of modules, together with

32+-- their dependency status, and discards dependency modules in the resulting

33+-- documentation.

2934--

30−convertModule :: P.Module -> Module

31−convertModule m@(P.Module _ coms moduleName _ _) =

32− Module (P.runModuleName moduleName) comments (declarations m)

35+convertModulesInPackage ::

36+ (Functor m, MonadError P.MultipleErrors m) =>

37+ P.Env ->

38+ [InPackage P.Module] ->

39+ m [Module]

40+convertModulesInPackage env modules =

41+ go modules

3342 where

34− comments = convertComments coms

35− declarations =

36− P.exportedDeclarations

37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)

38− >>> augmentDeclarations

39− >>> map addDefaultFixity

43+ localNames =

44+ map (P.runModuleName . P.getModuleName) (takeLocals modules)

45+ go =

46+ map ignorePackage

47+ >>> convertModules env

48+ >>> fmap (filter ((`elem` localNames) . modName))

4049

41−-- | The data type for an intermediate stage which we go through during

42−-- converting.

43−--

44−-- In the first pass, we take all top level declarations in the module, and

45−-- collect other information which will later be used to augment the top level

46−-- declarations. These two situation correspond to the Right and Left

47−-- constructors, respectively.

50+-- |

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

52+-- producing documentation from. It is also necessary to pass an Env containing

53+-- imports/exports information about the list of modules, which is needed for

54+-- documenting re-exports.

4855--

49−-- In the second pass, we go over all of the Left values and augment the

50−-- relevant declarations, leaving only the augmented Right values.

56+-- Preconditions:

5157--

52−-- Note that in the Left case, we provide a [String] as well as augment

53−-- information. The [String] value should be a list of titles of declarations

54−-- that the augmentation should apply to. For example, for a type instance

55−-- declaration, that would be any types or type classes mentioned in the

56−-- instance. For a fixity declaration, it would be just the relevant operator's

57−-- name.

58−type IntermediateDeclaration

59− = Either ([String], DeclarationAugment) Declaration

60−

61−-- | Some data which will be used to augment a Declaration in the

62−-- output.

58+-- * If any module in the list re-exports documentation from other

59+-- modules, those modules must also be included in the list.

60+-- * The modules passed must have had names desugared and re-exports

61+-- elaborated first.

6362--

64−-- The AugmentChild constructor allows us to move all children under their

65−-- respective parents. It is only necessary for type instance declarations,

66−-- since they appear at the top level in the AST, and since they might need to

67−-- appear as children in two places (for example, if a data type defined in a

68−-- module is an instance of a type class also defined in that module).

63+-- If either of these are not satisfied, an internal error will be thrown. To

64+-- avoid this, it is recommended to use

65+-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this

66+-- function.

6967--

70−-- The AugmentFixity constructor allows us to augment operator definitions

71−-- with their associativity and precedence.

72−data DeclarationAugment

73− = AugmentChild ChildDeclaration

74− | AugmentFixity P.Fixity (Maybe P.Ident)

68+convertModules ::

69+ (Functor m, MonadError P.MultipleErrors m) =>

70+ P.Env ->

71+ [P.Module] ->

72+ m [Module]

73+convertModules env =

74+ P.sortModules >>> fmap (convertSorted env . fst)

7575

76−-- | Augment top-level declarations; the second pass. See the comments under

77−-- the type synonym IntermediateDeclaration for more information.

78−augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]

79−augmentDeclarations (partitionEithers -> (augments, toplevels)) =

80− foldl go toplevels augments

81− where

82− go ds (parentTitles, a) =

83− map (\d ->

84− if declTitle d `elem` parentTitles

85− then augmentWith a d

86− else d) ds

87−

88− augmentWith a d =

89− case a of

90− AugmentChild child ->

91− d { declChildren = declChildren d ++ [child] }

92− AugmentFixity fixity alias ->

93− d { declFixity = Just (fixity, P.runIdent <$> alias) }

94−

95−-- | Add the default operator fixity for operators which do not have associated

96−-- fixity declarations.

76+-- |

77+-- Convert a sorted list of modules.

9778--

98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

99−-- in 0.9.

100−addDefaultFixity :: Declaration -> Declaration

101−addDefaultFixity decl@Declaration{..}

102− | isOp declTitle && isNothing declFixity =

103− decl { declFixity = Just (defaultFixity, Nothing) }

104− | otherwise =

105− decl

106− where

107− isOp :: String -> Bool

108− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str

109− defaultFixity = P.Fixity P.Infixl (-1)

110−

111−getDeclarationTitle :: P.Declaration -> Maybe String

112−getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)

113−getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

114−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

115−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)

116−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

117−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

118−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

119−getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

120−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

121−getDeclarationTitle _ = Nothing

122−

123−-- | Create a basic Declaration value.

124−mkDeclaration :: String -> DeclarationInfo -> Declaration

125−mkDeclaration title info =

126− Declaration { declTitle = title

127− , declComments = Nothing

128− , declSourceSpan = Nothing

129− , declChildren = []

130− , declFixity = Nothing

131− , declInfo = info

132− }

133−

134−basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration

135−basicDeclaration title info = Just $ Right $ mkDeclaration title info

136−

137−convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

138−convertDeclaration (P.TypeDeclaration _ ty) title =

139− basicDeclaration title (ValueDeclaration ty)

140−convertDeclaration (P.ExternDeclaration _ ty) title =

141− basicDeclaration title (ValueDeclaration ty)

142−convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

143− Just (Right (mkDeclaration title info) { declChildren = children })

144− where

145− info = DataDeclaration dtype args

146− children = map convertCtor ctors

147− convertCtor (ctor', tys) =

148− ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)

149−convertDeclaration (P.ExternDataDeclaration _ kind') title =

150− basicDeclaration title (ExternDataDeclaration kind')

151−convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

152− basicDeclaration title (TypeSynonymDeclaration args ty)

153−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

154− Just (Right (mkDeclaration title info) { declChildren = children })

155− where

156− info = TypeClassDeclaration args implies

157− children = map convertClassMember ds

158− convertClassMember (P.PositionedDeclaration _ _ d) =

159− convertClassMember d

160− convertClassMember (P.TypeDeclaration ident' ty) =

161− ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

162− convertClassMember _ =

163− P.internalError "convertDeclaration: Invalid argument to convertClassMember."

164−convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

165− Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

166− where

167− classNameString = unQual className

168− typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)

169− unQual x = let (P.Qualified _ y) = x in P.runProperName y

170−

171− extractProperNames (P.TypeConstructor n) = [unQual n]

172− extractProperNames _ = []

173−

174− childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

175− classApp = foldl P.TypeApp (P.TypeConstructor className) tys

176−convertDeclaration (P.FixityDeclaration fixity _ alias) title =

177− Just (Left ([title], AugmentFixity fixity alias))

178−convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

179− fmap (addComments . addSourceSpan) (convertDeclaration d' title)

180− where

181− addComments (Right d) =

182− Right (d { declComments = convertComments com })

183− addComments (Left augment) =

184− Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })

185− augment)

186−

187− addSourceSpan (Right d) =

188− Right (d { declSourceSpan = Just srcSpan })

189− addSourceSpan (Left augment) =

190− Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })

191− augment)

192−

193− withAugmentChild f (t, a) =

194− case a of

195− AugmentChild d -> (t, AugmentChild (f d))

196− _ -> (t, a)

197−convertDeclaration _ _ = Nothing

198−

199−convertComments :: [P.Comment] -> Maybe String

200−convertComments cs = do

201− let raw = concatMap toLines cs

202− guard (all hasPipe raw && not (null raw))

203− return (go raw)

204− where

205− go = unlines . map stripPipes

206−

207− toLines (P.LineComment s) = [s]

208− toLines (P.BlockComment s) = lines s

209−

210− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

211−

212− stripPipes = dropPipe . dropWhile (== ' ')

213−

214− dropPipe ('|':' ':s) = s

215− dropPipe ('|':s) = s

216− dropPipe s = s

217−

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

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

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

221−collectBookmarks :: InPackage P.Module -> [Bookmark]

222−collectBookmarks (Local m) = map Local (collectBookmarks' m)

223−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

224−

225−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]

226−collectBookmarks' m =

227− map (P.getModuleName m, )

228− (mapMaybe getDeclarationTitle

229− (P.exportedDeclarations m))

79+convertSorted :: P.Env -> [P.Module] -> [Module]

80+convertSorted env modules =

81+ let

82+ traversalOrder =

83+ map P.getModuleName modules

84+ moduleMap =

85+ Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules

86+ in

87+ Map.elems (updateReExports env traversalOrder moduleMap)

src/Language/PureScript/Docs/Convert/ReExports.hsnew file+444

@@ -0,0 +1,444 @@

1+{-# LANGUAGE ViewPatterns #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE FlexibleContexts #-}

6+module Language.PureScript.Docs.Convert.ReExports

7+ ( updateReExports

8+ ) where

10+import Prelude ()

11+import Prelude.Compat

12+

13+import Control.Monad

14+import Control.Monad.Trans.State.Strict (execState)

15+import Control.Monad.State.Class (MonadState, gets, modify)

16+import Control.Arrow ((&&&), first, second)

17+import Data.Either

18+import Data.Maybe (mapMaybe)

19+import Data.Map (Map)

20+import qualified Data.Map as Map

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

22+

23+import qualified Language.PureScript as P

24+

25+import Language.PureScript.Docs.Types

26+

27+-- |

28+-- Given:

29+--

30+-- * The Imports/Exports Env

31+-- * An order to traverse the modules (which must be topological)

32+-- * A map of modules, indexed by their names, which are assumed to not

33+-- have their re-exports listed yet

34+--

35+-- This function adds all the missing re-exports.

36+--

37+updateReExports ::

38+ P.Env ->

39+ [P.ModuleName] ->

40+ Map P.ModuleName Module ->

41+ Map P.ModuleName Module

42+updateReExports env order modules =

43+ execState action modules

44+ where

45+ action =

46+ void (traverse go order)

47+

48+ go mn = do

49+ mdl <- lookup' mn

50+ reExports <- getReExports env mn

51+ let mdl' = mdl { modReExports = reExports }

52+ modify (Map.insert mn mdl')

53+

54+ lookup' mn = do

55+ v <- gets (Map.lookup mn)

56+ case v of

57+ Just v' ->

58+ pure v'

59+ Nothing ->

60+ internalError ("Module missing: " ++ P.runModuleName mn)

61+

62+-- |

63+-- Collect all of the re-exported declarations for a single module.

64+--

65+-- We require that modules have already been sorted (P.sortModules) in order to

66+-- ensure that by the time we convert a particular module, all its dependencies

67+-- have already been converted.

68+--

69+getReExports ::

70+ (Functor m, Applicative m,

71+ MonadState (Map P.ModuleName Module) m) =>

72+ P.Env ->

73+ P.ModuleName ->

74+ m [(P.ModuleName, [Declaration])]

75+getReExports env mn =

76+ case Map.lookup mn env of

77+ Nothing ->

78+ internalError ("Module missing: " ++ P.runModuleName mn)

79+ Just (_, imports, exports) ->

80+ let notLocal = (/= mn) . fst

81+ in filter notLocal <$> collectDeclarations imports exports

82+

83+-- |

84+-- Assemble a list of declarations re-exported from a particular module, based

85+-- on the Imports and Exports value for that module, and by extracting the

86+-- declarations from the current state.

87+--

88+-- This function works by searching through the lists of exported declarations

89+-- in the Exports, and looking them up in the associated Imports value to find

90+-- the module they were imported from.

91+--

92+-- Additionally:

93+--

94+-- * Attempts to move re-exported type class members under their parent

95+-- type classes, if possible, or otherwise, "promote" them from

96+-- ChildDeclarations to proper Declarations.

97+-- * Filters data declarations to ensure that only re-exported data

98+-- constructors are listed.

99+-- * Filters type class declarations to ensure that only re-exported type

100+-- class members are listed.

101+--

102+collectDeclarations ::

103+ (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>

104+ P.Imports ->

105+ P.Exports ->

106+ m [(P.ModuleName, [Declaration])]

107+collectDeclarations imports exports = do

108+ valsAndMembers <- collect lookupValueDeclaration impVals expVals

109+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

110+ types <- collect lookupTypeDeclaration impTypes expTypes

111+

112+ let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses

113+

114+ let filteredTypes = filterDataConstructors expCtors types

115+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes

116+

117+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

118+

119+ where

120+ collect lookup' imps exps =

121+ Map.fromListWith (<>) <$> traverse (uncurry lookup')

122+ (map (findImport imps) exps)

123+

124+ expVals = P.exportedValues exports

125+ impVals = concat (Map.elems (P.importedValues imports))

126+

127+ expTypes = map (first fst) (P.exportedTypes exports)

128+ impTypes = concat (Map.elems (P.importedTypes imports))

129+

130+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)

131+

132+ expTCs = P.exportedTypeClasses exports

133+ impTCs = concat (Map.elems (P.importedTypeClasses imports))

134+

135+-- |

136+-- Given a list of imported declarations (of a particular kind, ie. type, data,

137+-- class, value, etc), and the name of an exported declaration of the same

138+-- kind, together with the module it was originally defined in, return a tuple

139+-- of:

140+--

141+-- * the module that exported declaration was imported from (note that

142+-- this can be different from the module it was originally defined in, if

143+-- it is a re-export),

144+-- * that same declaration's name.

145+--

146+-- This function uses a type variable for names because we want to be able to

147+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

148+--

149+findImport ::

150+ (Show name, Eq name) =>

151+ [(P.Qualified name, P.ModuleName)] ->

152+ (name, P.ModuleName) ->

153+ (P.ModuleName, name)

154+findImport imps (name, orig) =

155+ case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of

156+ [(P.Qualified (Just importedFrom) _, _)] ->

157+ (importedFrom, name)

158+ other ->

159+ internalError ("findImport: unexpected result: " ++ show other)

160+

161+lookupValueDeclaration ::

162+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>

163+ P.ModuleName ->

164+ P.Ident ->

165+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

166+lookupValueDeclaration importedFrom ident = do

167+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom

168+ let

169+ rs =

170+ filter (\d -> declTitle d == P.showIdent ident

171+ && (isValue d || isAlias d)) decls

172+ errOther other =

173+ internalError

174+ ("lookupValueDeclaration: unexpected result:\n" ++

175+ "other: " ++ show other ++ "\n" ++

176+ "ident: " ++ show ident ++ "\n" ++

177+ "decls: " ++ show decls)

178+

179+ case rs of

180+ [r] ->

181+ pure (importedFrom, [Right r])

182+ [] ->

183+ -- It's a type class member.

184+ -- Note that we need to filter based on the child declaration info using

185+ -- `isTypeClassMember` anyway, because child declarations of type classes

186+ -- are not necessarily members; they could also be instances.

187+ let

188+ allTypeClassChildDecls =

189+ decls

190+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)

191+ |> concatMap (\(d, constr) ->

192+ map (declTitle d, constr,)

193+ (declChildren d))

194+

195+ matchesIdent cdecl =

196+ cdeclTitle cdecl == P.showIdent ident

197+

198+ matchesAndIsTypeClassMember =

199+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)

200+

201+ in

202+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of

203+ [r'] ->

204+ pure (importedFrom, [Left r'])

205+ other ->

206+ errOther other

207+ other -> do

208+ errOther other

209+

210+ where

211+ thd :: (a, b, c) -> c

212+ thd (_, _, x) = x

213+

214+-- |

215+-- Extract a particular type declaration. For data declarations, constructors

216+-- are only included in the output if they are listed in the arguments.

217+--

218+lookupTypeDeclaration ::

219+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>

220+ P.ModuleName ->

221+ P.ProperName 'P.TypeName ->

222+ m (P.ModuleName, [Declaration])

223+lookupTypeDeclaration importedFrom ty = do

224+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom

225+ let

226+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls

227+ case ds of

228+ [d] ->

229+ pure (importedFrom, [d])

230+ other ->

231+ internalError

232+ ("lookupTypeDeclaration: unexpected result: " ++ show other)

233+

234+lookupTypeClassDeclaration ::

235+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>

236+ P.ModuleName ->

237+ P.ProperName 'P.ClassName ->

238+ m (P.ModuleName, [Declaration])

239+lookupTypeClassDeclaration importedFrom tyClass = do

240+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

241+ let

242+ ds = filter (\d -> declTitle d == P.runProperName tyClass

243+ && isTypeClass d)

244+ decls

245+ case ds of

246+ [d] ->

247+ pure (importedFrom, [d])

248+ other ->

249+ internalError ("lookupTypeClassDeclaration: unexpected result: "

250+ ++ (unlines . map show) other)

251+

252+-- |

253+-- Get the full list of declarations for a particular module out of the

254+-- state, or raise an internal error if it is not there.

255+--

256+lookupModuleDeclarations ::

257+ (Applicative m, MonadState (Map P.ModuleName Module) m) =>

258+ String ->

259+ P.ModuleName ->

260+ m [Declaration]

261+lookupModuleDeclarations definedIn moduleName = do

262+ mmdl <- gets (Map.lookup moduleName)

263+ case mmdl of

264+ Nothing ->

265+ internalError (definedIn ++ ": module missing: "

266+ ++ P.runModuleName moduleName)

267+ Just mdl ->

268+ pure (allDeclarations mdl)

269+

270+handleTypeClassMembers ::

271+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

272+ Map P.ModuleName [Declaration] ->

273+ (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

274+handleTypeClassMembers valsAndMembers typeClasses =

275+ let

276+ moduleEnvs =

277+ Map.unionWith (<>)

278+ (fmap valsAndMembersToEnv valsAndMembers)

279+ (fmap typeClassesToEnv typeClasses)

280+ in

281+ moduleEnvs

282+ |> fmap handleEnv

283+ |> splitMap

284+

285+valsAndMembersToEnv ::

286+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

287+valsAndMembersToEnv xs =

288+ let (envUnhandledMembers, envValues) = partitionEithers xs

289+ envTypeClasses = []

290+ in TypeClassEnv{..}

291+

292+typeClassesToEnv :: [Declaration] -> TypeClassEnv

293+typeClassesToEnv classes =

294+ TypeClassEnv

295+ { envUnhandledMembers = []

296+ , envValues = []

297+ , envTypeClasses = classes

298+ }

299+

300+-- |

301+-- An intermediate data type, used for either moving type class members under

302+-- their parent type classes, or promoting them to normal Declaration values

303+-- if their parent type class has not been re-exported.

304+--

305+data TypeClassEnv = TypeClassEnv

306+ { -- |

307+ -- Type class members which have not yet been dealt with. The String is the

308+ -- name of the type class they belong to, and the constraint is used to

309+ -- make sure that they have the correct type if they get promoted.

310+ --

311+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]

312+ -- |

313+ -- A list of normal value declarations. Type class members will be added to

314+ -- this list if their parent type class is not available.

315+ --

316+ , envValues :: [Declaration]

317+ -- |

318+ -- A list of type class declarations. Type class members will be added to

319+ -- their parents in this list, if they exist.

320+ --

321+ , envTypeClasses :: [Declaration]

322+ }

323+ deriving (Show)

324+

325+instance Monoid TypeClassEnv where

326+ mempty =

327+ TypeClassEnv mempty mempty mempty

328+ mappend (TypeClassEnv a1 b1 c1)

329+ (TypeClassEnv a2 b2 c2) =

330+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)

331+

332+-- |

333+-- Take a TypeClassEnv and handle all of the type class members in it, either

334+-- adding them to their parent classes, or promoting them to normal Declaration

335+-- values.

336+--

337+-- Returns a tuple of (values, type classes).

338+--

339+handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])

340+handleEnv TypeClassEnv{..} =

341+ envUnhandledMembers

342+ |> foldl go (envValues, mkMap envTypeClasses)

343+ |> second Map.elems

344+

345+ where

346+ mkMap =

347+ Map.fromList . map (declTitle &&& id)

348+

349+ go (values, tcs) (title, constraint, childDecl) =

350+ case Map.lookup title tcs of

351+ Just _ ->

352+ -- Leave the state unchanged; if the type class is there, the child

353+ -- will be too.

354+ (values, tcs)

355+ Nothing ->

356+ (promoteChild constraint childDecl : values, tcs)

357+

358+ promoteChild constraint ChildDeclaration{..} =

359+ case cdeclInfo of

360+ ChildTypeClassMember typ ->

361+ Declaration

362+ { declTitle = cdeclTitle

363+ , declComments = cdeclComments

364+ , declSourceSpan = cdeclSourceSpan

365+ , declChildren = []

366+ , declFixity = Nothing

367+ , declInfo = ValueDeclaration (addConstraint constraint typ)

368+ }

369+ _ ->

370+ internalError

371+ ("handleEnv: Bad child declaration passed to promoteChild: "

372+ ++ cdeclTitle)

373+

374+ addConstraint constraint =

375+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]

376+

377+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)

378+splitMap = foldl go (Map.empty, Map.empty) . Map.toList

379+ where

380+ go (m1, m2) (k, (v1, v2)) =

381+ (Map.insert k v1 m1, Map.insert k v2 m2)

382+

383+-- |

384+-- Given a list of exported constructor names, remove any data constructor

385+-- names in the provided Map of declarations which are not in the list.

386+--

387+filterDataConstructors ::

388+ [P.ProperName 'P.ConstructorName] ->

389+ Map P.ModuleName [Declaration] ->

390+ Map P.ModuleName [Declaration]

391+filterDataConstructors =

392+ filterExportedChildren isDataConstructor P.runProperName

393+

394+-- |

395+-- Given a list of exported type class member names, remove any data

396+-- type class member names in the provided Map of declarations which are not in

397+-- the list.

398+--

399+filterTypeClassMembers ::

400+ [P.Ident] ->

401+ Map P.ModuleName [Declaration] ->

402+ Map P.ModuleName [Declaration]

403+filterTypeClassMembers =

404+ filterExportedChildren isTypeClassMember P.showIdent

405+

406+filterExportedChildren ::

407+ (Functor f) =>

408+ (ChildDeclaration -> Bool) ->

409+ (name -> String) ->

410+ [name] ->

411+ f [Declaration] ->

412+ f [Declaration]

413+filterExportedChildren isTargetedKind runName expNames =

414+ fmap filterDecls

415+ where

416+ filterDecls =

417+ map (filterChildren (\c -> not (isTargetedKind c) ||

418+ cdeclTitle c `elem` expNames'))

419+

420+ expNames' = map runName expNames

421+

422+allDeclarations :: Module -> [Declaration]

423+allDeclarations Module{..} =

424+ modDeclarations ++ concatMap snd modReExports

425+

426+(|>) :: a -> (a -> b) -> b

427+x |> f = f x

428+

429+internalError :: String -> a

430+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

431+

432+-- |

433+-- If the provided Declaration is a TypeClassDeclaration, construct an

434+-- appropriate Constraint for use with the types of its members.

435+--

436+typeClassConstraintFor :: Declaration -> Maybe P.Constraint

437+typeClassConstraintFor Declaration{..} =

438+ case declInfo of

439+ TypeClassDeclaration tyArgs _ ->

440+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)

441+ _ ->

442+ Nothing

443+ where

444+ mkConstraint = map (P.TypeVar . fst)

src/Language/PureScript/Docs/Convert/Single.hsnew file+232

@@ -0,0 +1,232 @@

1+{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE ViewPatterns #-}

5+{-# LANGUAGE FlexibleContexts #-}

7+module Language.PureScript.Docs.Convert.Single

8+ ( convertSingleModule

9+ , collectBookmarks

10+ ) where

11+

12+import Prelude ()

13+import Prelude.Compat

14+import Data.Maybe (catMaybes)

15+

16+import Control.Monad

17+import Control.Category ((>>>))

18+import Data.Maybe (mapMaybe, isNothing)

19+import Data.Either

20+import Data.List (nub, isPrefixOf, isSuffixOf)

21+

22+import qualified Language.PureScript as P

23+

24+import Language.PureScript.Docs.Types

25+

26+-- |

27+-- Convert a single Module, but ignore re-exports; any re-exported types or

28+-- values will not appear in the result.

29+--

30+convertSingleModule :: P.Module -> Module

31+convertSingleModule m@(P.Module _ coms moduleName _ _) =

32+ Module (P.runModuleName moduleName) comments (declarations m) []

33+ where

34+ comments = convertComments coms

35+ declarations =

36+ P.exportedDeclarations

37+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)

38+ >>> augmentDeclarations

39+ >>> map addDefaultFixity

40+

41+-- | The data type for an intermediate stage which we go through during

42+-- converting.

43+--

44+-- In the first pass, we take all top level declarations in the module, and

45+-- collect other information which will later be used to augment the top level

46+-- declarations. These two situation correspond to the Right and Left

47+-- constructors, respectively.

48+--

49+-- In the second pass, we go over all of the Left values and augment the

50+-- relevant declarations, leaving only the augmented Right values.

51+--

52+-- Note that in the Left case, we provide a [String] as well as augment

53+-- information. The [String] value should be a list of titles of declarations

54+-- that the augmentation should apply to. For example, for a type instance

55+-- declaration, that would be any types or type classes mentioned in the

56+-- instance. For a fixity declaration, it would be just the relevant operator's

57+-- name.

58+type IntermediateDeclaration

59+ = Either ([String], DeclarationAugment) Declaration

60+

61+-- | Some data which will be used to augment a Declaration in the

62+-- output.

63+--

64+-- The AugmentChild constructor allows us to move all children under their

65+-- respective parents. It is only necessary for type instance declarations,

66+-- since they appear at the top level in the AST, and since they might need to

67+-- appear as children in two places (for example, if a data type defined in a

68+-- module is an instance of a type class also defined in that module).

69+--

70+-- The AugmentFixity constructor allows us to augment operator definitions

71+-- with their associativity and precedence.

72+data DeclarationAugment

73+ = AugmentChild ChildDeclaration

74+ | AugmentFixity P.Fixity

75+

76+-- | Augment top-level declarations; the second pass. See the comments under

77+-- the type synonym IntermediateDeclaration for more information.

78+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]

79+augmentDeclarations (partitionEithers -> (augments, toplevels)) =

80+ foldl go toplevels augments

81+ where

82+ go ds (parentTitles, a) =

83+ map (\d ->

84+ if declTitle d `elem` parentTitles

85+ then augmentWith a d

86+ else d) ds

87+

88+ augmentWith a d =

89+ case a of

90+ AugmentChild child ->

91+ d { declChildren = declChildren d ++ [child] }

92+ AugmentFixity fixity ->

93+ d { declFixity = Just fixity }

94+

95+-- | Add the default operator fixity for operators which do not have associated

96+-- fixity declarations.

97+--

98+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

99+-- in 0.9.

100+addDefaultFixity :: Declaration -> Declaration

101+addDefaultFixity decl@Declaration{..}

102+ | isOp declTitle && isNothing declFixity =

103+ decl { declFixity = Just defaultFixity }

104+ | otherwise =

105+ decl

106+ where

107+ isOp :: String -> Bool

108+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str

109+ defaultFixity = P.Fixity P.Infixl (-1)

110+

111+getDeclarationTitle :: P.Declaration -> Maybe String

112+getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)

113+getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

114+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

115+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)

116+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

117+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

118+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

119+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

120+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

121+getDeclarationTitle _ = Nothing

122+

123+-- | Create a basic Declaration value.

124+mkDeclaration :: String -> DeclarationInfo -> Declaration

125+mkDeclaration title info =

126+ Declaration { declTitle = title

127+ , declComments = Nothing

128+ , declSourceSpan = Nothing

129+ , declChildren = []

130+ , declFixity = Nothing

131+ , declInfo = info

132+ }

133+

134+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration

135+basicDeclaration title info = Just $ Right $ mkDeclaration title info

136+

137+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

138+convertDeclaration (P.TypeDeclaration _ ty) title =

139+ basicDeclaration title (ValueDeclaration ty)

140+convertDeclaration (P.ExternDeclaration _ ty) title =

141+ basicDeclaration title (ValueDeclaration ty)

142+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

143+ Just (Right (mkDeclaration title info) { declChildren = children })

144+ where

145+ info = DataDeclaration dtype args

146+ children = map convertCtor ctors

147+ convertCtor (ctor', tys) =

148+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)

149+convertDeclaration (P.ExternDataDeclaration _ kind') title =

150+ basicDeclaration title (ExternDataDeclaration kind')

151+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

152+ basicDeclaration title (TypeSynonymDeclaration args ty)

153+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

154+ Just (Right (mkDeclaration title info) { declChildren = children })

155+ where

156+ info = TypeClassDeclaration args implies

157+ children = map convertClassMember ds

158+ convertClassMember (P.PositionedDeclaration _ _ d) =

159+ convertClassMember d

160+ convertClassMember (P.TypeDeclaration ident' ty) =

161+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

162+ convertClassMember _ =

163+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."

164+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

165+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

166+ where

167+ classNameString = unQual className

168+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)

169+ unQual x = let (P.Qualified _ y) = x in P.runProperName y

170+

171+ extractProperNames (P.TypeConstructor n) = [unQual n]

172+ extractProperNames _ = []

173+

174+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

175+ classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys

176+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =

177+ Just (Left ([title], AugmentFixity fixity))

178+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =

179+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }

180+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

181+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)

182+ where

183+ addComments (Right d) =

184+ Right (d { declComments = convertComments com })

185+ addComments (Left augment) =

186+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })

187+ augment)

188+

189+ addSourceSpan (Right d) =

190+ Right (d { declSourceSpan = Just srcSpan })

191+ addSourceSpan (Left augment) =

192+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })

193+ augment)

194+

195+ withAugmentChild f (t, a) =

196+ case a of

197+ AugmentChild d -> (t, AugmentChild (f d))

198+ _ -> (t, a)

199+convertDeclaration _ _ = Nothing

200+

201+convertComments :: [P.Comment] -> Maybe String

202+convertComments cs = do

203+ let raw = concatMap toLines cs

204+ let docs = catMaybes (map stripPipe raw)

205+ guard (not (null docs))

206+ pure (unlines docs)

207+

208+ where

209+ toLines (P.LineComment s) = [s]

210+ toLines (P.BlockComment s) = lines s

211+

212+ stripPipe s' =

213+ case dropWhile (== ' ') s' of

214+ ('|':' ':s) ->

215+ Just s

216+ ('|':s) ->

217+ Just s

218+ _ ->

219+ Nothing

220+

221+-- | Go through a PureScript module and extract a list of Bookmarks; references

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

223+-- generating links in the HTML documentation, for example.

224+collectBookmarks :: InPackage P.Module -> [Bookmark]

225+collectBookmarks (Local m) = map Local (collectBookmarks' m)

226+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

227+

228+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]

229+collectBookmarks' m =

230+ map (P.getModuleName m, )

231+ (mapMaybe getDeclarationTitle

232+ (P.exportedDeclarations m))

src/Language/PureScript/Docs/ParseAndDesugar.hs+36−35

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

11{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE FlexibleContexts #-}

34module Language.PureScript.Docs.ParseAndDesugar

45 ( parseAndDesugar

5− , ParseDesugarError(..)

66 ) where

88import Prelude ()

@@ -12,7 +12,6 @@ import qualified Data.Map as M

1212import Control.Arrow (first)

1313import Control.Monad

1414

15−import Control.Monad.Trans.Except

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

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

1817import Control.Monad.IO.Class (MonadIO(..))

@@ -24,73 +23,69 @@ import qualified Language.PureScript.Constants as C

2423import Language.PureScript.Docs.Types

2524import Language.PureScript.Docs.Convert (collectBookmarks)

2625

27−data ParseDesugarError

28− = ParseError P.MultipleErrors

29− | SortModulesError P.MultipleErrors

30− | DesugarError P.MultipleErrors

31− deriving (Show)

32−

3326-- |

3427-- Given:

3528--

3629-- * A list of local source files

3730-- * A list of source files from external dependencies, together with their

3831-- package names

39−-- * A callback, taking a list of bookmarks, and a list of desugared modules

4032--

4133-- This function does the following:

4234--

4335-- * Parse all of the input and dependency source files

44−-- * Partially desugar all of the resulting modules

36+-- * Associate each dependency module with its package name, thereby

37+-- distinguishing these from local modules

38+-- * Partially desugar all of the resulting modules (just enough for

39+-- producing documentation from them)

4540-- * Collect a list of bookmarks from the whole set of source files

46−-- * Collect a list of desugared modules from just the input source files (not

47−-- dependencies)

48−-- * Call the callback with the bookmarks and desugared module list.

41+-- * Return the desugared modules, the bookmarks, and the imports/exports

42+-- Env (which is needed for producing documentation).

4943parseAndDesugar ::

44+ (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

5045 [FilePath]

5146 -> [(PackageName, FilePath)]

52− -> ([Bookmark] -> [P.Module] -> IO a)

53− -> IO (Either ParseDesugarError a)

54−parseAndDesugar inputFiles depsFiles callback = do

47+ -> m ([InPackage P.Module], [Bookmark], P.Env)

48+parseAndDesugar inputFiles depsFiles = do

5549 inputFiles' <- traverse (parseAs Local) inputFiles

5650 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

5751

58− runExceptT $ do

59− ms <- parseFiles (inputFiles' ++ depsFiles')

60− ms' <- sortModules (map snd ms)

61− (bs, ms'') <- desugarWithBookmarks ms ms'

62− liftIO $ callback bs ms''

52+ ms <- parseFiles (inputFiles' ++ depsFiles')

53+ ms' <- sortModules (map snd ms)

54+ desugarWithBookmarks ms ms'

6355

6456parseFiles ::

57+ (MonadError P.MultipleErrors m, MonadIO m) =>

6558 [(FileInfo, FilePath)]

66− -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]

59+ -> m [(FileInfo, P.Module)]

6760parseFiles =

68− throwLeft ParseError . P.parseModulesFromFiles fileInfoToString

61+ throwLeft . P.parseModulesFromFiles fileInfoToString

6962

7063sortModules ::

64+ (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>

7165 [P.Module]

72− -> ExceptT ParseDesugarError IO [P.Module]

66+ -> m [P.Module]

7367sortModules =

74− fmap fst . throwLeft SortModulesError . sortModules' . map importPrim

68+ fmap fst . throwLeft . sortModules' . map importPrim

7569 where

7670 sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)

7771 sortModules' = P.sortModules

7872

7973desugarWithBookmarks ::

74+ (MonadError P.MultipleErrors m, MonadIO m) =>

8075 [(FileInfo, P.Module)]

8176 -> [P.Module]

82− -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])

77+ -> m ([InPackage P.Module], [Bookmark], P.Env)

8378desugarWithBookmarks msInfo msSorted = do

84− msDesugared <- throwLeft DesugarError (desugar msSorted)

79+ (env, msDesugared) <- throwLeft (desugar msSorted)

8580

8681 let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

8782 msPackages = map (addPackage msDeps) msDesugared

8883 bookmarks = concatMap collectBookmarks msPackages

8984

90− return (bookmarks, takeLocals msPackages)

85+ return (msPackages, bookmarks, env)

9186

92−throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r

93−throwLeft f = either (throwError . f) return

87+throwLeft :: (MonadError l m) => Either l r -> m r

88+throwLeft = either throwError return

9489

9590-- | Specifies whether a PureScript source file is considered as:

9691--

@@ -108,18 +103,24 @@ fileInfoToString (FromDep _ fn) = fn

108103importPrim :: P.Module -> P.Module

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

110105

111−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

106+desugar ::

107+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

108+ [P.Module]

109+ -> m (P.Env, [P.Module])

112110desugar = P.evalSupplyT 0 . desugar'

113111 where

114− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

115− desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []

112+ desugar' =

113+ traverse P.desugarDoModule

114+ >=> P.desugarCasesModule

115+ >=> ignoreWarnings . P.desugarImportsWithEnv []

116+

116117 ignoreWarnings m = liftM fst (runWriterT m)

117118

118119parseFile :: FilePath -> IO (FilePath, String)

119120parseFile input' = (,) input' <$> readFile input'

120121

121−parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)

122−parseAs g = fmap (first g) . parseFile

122+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)

123+parseAs g = fmap (first g) . liftIO . parseFile

123124

124125getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

125126getDepsModuleNames = foldl go M.empty

src/Language/PureScript/Docs/Render.hs+15−7

@@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} =

4949 [ keywordClass ]

5050 ++ maybeToList superclasses

5151 ++ [renderType' (typeApp declTitle args)]

52− ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]

52+ ++ [keywordWhere | any isTypeClassMember declChildren]

5353

5454 where

5555 superclasses

@@ -58,11 +58,19 @@ renderDeclarationWithOptions opts Declaration{..} =

5858 syntax "("

5959 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

6060 <> syntax ")" <> sp <> syntax "<="

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

62+ [ keywordFixity associativity

63+ , syntax $ show precedence

64+ , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for

65+ , keyword "as"

66+ , ident . tail . init $ declTitle

67+ ]

6168

62− isTypeClassMember (ChildTypeClassMember _) = True

63− isTypeClassMember _ = False

6469 where

6570 renderType' = renderTypeWithOptions opts

71+ dequalifyCurrentModule (P.Qualified mn a)

72+ | mn == currentModule opts = P.Qualified Nothing a

73+ | otherwise = P.Qualified mn a

6674

6775renderChildDeclaration :: ChildDeclaration -> RenderedCode

6876renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

@@ -86,12 +94,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

8694 where

8795 renderType' = renderTypeWithOptions opts

8896

89−renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

97+renderConstraint :: P.Constraint -> RenderedCode

9098renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

9199

92−renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

100+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode

93101renderConstraintWithOptions opts (pn, tys) =

94− renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys

102+ renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys

95103

96104renderConstraints :: [P.Constraint] -> Maybe RenderedCode

97105renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

@@ -108,7 +116,7 @@ renderConstraintsWithOptions opts constraints

108116 mintersperse (syntax "," <> sp)

109117 (map (renderConstraintWithOptions opts) constraints)

110118

111−notQualified :: String -> P.Qualified P.ProperName

119+notQualified :: String -> P.Qualified (P.ProperName a)

112120notQualified = P.Qualified Nothing . P.ProperName

113121

114122typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type

src/Language/PureScript/Docs/RenderedCode/Render.hs+10−4

@@ -9,7 +9,7 @@ module Language.PureScript.Docs.RenderedCode.Render (

99 defaultRenderTypeOptions,

1010 renderTypeWithOptions

1111) where

12−

12+

1313import Prelude ()

1414import Prelude.Compat

1515

@@ -52,9 +52,10 @@ typeLiterals = mkPattern match

5252 ]

5353 where

5454 constraints = mintersperse (syntax "," <> sp) (map renderDep deps)

55+ renderDep :: Constraint -> RenderedCode

5556 renderDep (pn, tys) =

56− let instApp = foldl TypeApp (TypeConstructor pn) tys

57− in renderType instApp

57+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys

58+ in renderType instApp

5859 match REmpty =

5960 Just (syntax "()")

6061 match row@RCons{} =

@@ -172,10 +173,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions

172173

173174data RenderTypeOptions = RenderTypeOptions

174175 { prettyPrintObjects :: Bool

176+ , currentModule :: Maybe ModuleName

175177 }

176178

177179defaultRenderTypeOptions :: RenderTypeOptions

178−defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }

180+defaultRenderTypeOptions =

181+ RenderTypeOptions

182+ { prettyPrintObjects = True

183+ , currentModule = Nothing

184+ }

179185

180186renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

181187renderTypeWithOptions opts =

src/Language/PureScript/Docs/RenderedCode/Types.hs+6

@@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types

2828 , keywordClass

2929 , keywordInstance

3030 , keywordWhere

31+ , keywordFixity

3132 ) where

3233

3334import Prelude ()

@@ -189,3 +190,8 @@ keywordInstance = keyword "instance"

189190

190191keywordWhere :: RenderedCode

191192keywordWhere = keyword "where"

193+

194+keywordFixity :: P.Associativity -> RenderedCode

195+keywordFixity P.Infixl = keyword "infixl"

196+keywordFixity P.Infixr = keyword "infixr"

197+keywordFixity P.Infix = keyword "infix"

src/Language/PureScript/Docs/Types.hs+86−14

@@ -76,6 +76,8 @@ data Module = Module

7676 { modName :: String

7777 , modComments :: Maybe String

7878 , modDeclarations :: [Declaration]

79+ -- Re-exported values from other modules

80+ , modReExports :: [(P.ModuleName, [Declaration])]

7981 }

8082 deriving (Show, Eq, Ord)

8183

@@ -84,7 +86,7 @@ data Declaration = Declaration

8486 , declComments :: Maybe String

8587 , declSourceSpan :: Maybe P.SourceSpan

8688 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe (P.Fixity, Maybe String)

89+ , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9

8890 , declInfo :: DeclarationInfo

8991 }

9092 deriving (Show, Eq, Ord)

@@ -126,6 +128,12 @@ data DeclarationInfo

126128 -- members are represented as child declarations.

127129 --

128130 | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

131+

132+ -- |

133+ -- An operator alias declaration, with the member the alias is for and the

134+ -- operator's fixity.

135+ --

136+ | AliasDeclaration (P.Qualified P.Ident) P.Fixity

129137 deriving (Show, Eq, Ord)

130138

131139declInfoToString :: DeclarationInfo -> String

@@ -134,6 +142,38 @@ declInfoToString (DataDeclaration _ _) = "data"

134142declInfoToString (ExternDataDeclaration _) = "externData"

135143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

136144declInfoToString (TypeClassDeclaration _ _) = "typeClass"

145+declInfoToString (AliasDeclaration _ _) = "alias"

146+

147+isTypeClass :: Declaration -> Bool

148+isTypeClass Declaration{..} =

149+ case declInfo of

150+ TypeClassDeclaration{} -> True

151+ _ -> False

152+

153+isValue :: Declaration -> Bool

154+isValue Declaration{..} =

155+ case declInfo of

156+ ValueDeclaration{} -> True

157+ _ -> False

158+

159+isType :: Declaration -> Bool

160+isType Declaration{..} =

161+ case declInfo of

162+ TypeSynonymDeclaration{} -> True

163+ DataDeclaration{} -> True

164+ ExternDataDeclaration{} -> True

165+ _ -> False

166+

167+isAlias :: Declaration -> Bool

168+isAlias Declaration{..} =

169+ case declInfo of

170+ AliasDeclaration{} -> True

171+ _ -> False

172+

173+-- | Discard any children which do not satisfy the given predicate.

174+filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration

175+filterChildren p decl =

176+ decl { declChildren = filter p (declChildren decl) }

137177

138178data ChildDeclaration = ChildDeclaration

139179 { cdeclTitle :: String

@@ -167,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"

167207childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

168208childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

169209

210+isTypeClassMember :: ChildDeclaration -> Bool

211+isTypeClassMember ChildDeclaration{..} =

212+ case cdeclInfo of

213+ ChildTypeClassMember{} -> True

214+ _ -> False

215+

216+isDataConstructor :: ChildDeclaration -> Bool

217+isDataConstructor ChildDeclaration{..} =

218+ case cdeclInfo of

219+ ChildDataConstructor{} -> True

220+ _ -> False

221+

170222newtype GithubUser

171223 = GithubUser { runGithubUser :: String }

172224 deriving (Show, Eq, Ord)

@@ -297,6 +349,7 @@ asModule =

297349 Module <$> key "name" asString

298350 <*> key "comments" (perhaps asString)

299351 <*> key "declarations" (eachInArray asDeclaration)

352+ <*> key "reExports" (eachInArray asReExport)

300353

301354asDeclaration :: Parse PackageError Declaration

302355asDeclaration =

@@ -307,12 +360,23 @@ asDeclaration =

307360 <*> key "fixity" (perhaps asFixity)

308361 <*> key "info" asDeclarationInfo

309362

310−asFixity :: Parse PackageError (P.Fixity, Maybe String)

311−asFixity = do

312− fixity <- P.Fixity <$> key "associativity" asAssociativity

313− <*> key "precedence" asIntegral

314− alias <- keyMay "alias" asString

315− return (fixity, alias)

363+asReExport :: Parse PackageError (P.ModuleName, [Declaration])

364+asReExport =

365+ (,) <$> key "moduleName" fromAesonParser

366+ <*> key "declarations" (eachInArray asDeclaration)

367+

368+asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)

369+asInPackage inner =

370+ build <$> key "package" (perhaps (withString parsePackageName))

371+ <*> key "item" inner

372+ where

373+ build Nothing = Local

374+ build (Just pn) = FromDep pn

375+

376+asFixity :: Parse PackageError P.Fixity

377+asFixity =

378+ P.Fixity <$> key "associativity" asAssociativity

379+ <*> key "precedence" asIntegral

316380

317381parseAssociativity :: String -> Maybe P.Associativity

318382parseAssociativity str = case str of

@@ -341,6 +405,9 @@ asDeclarationInfo = do

341405 "typeClass" ->

342406 TypeClassDeclaration <$> key "arguments" asTypeArguments

343407 <*> key "superclasses" (eachInArray asConstraint)

408+ "alias" ->

409+ AliasDeclaration <$> key "for" asQualifiedIdent

410+ <*> key "fixity" asFixity

344411 other ->

345412 throwCustomError (InvalidDeclarationType other)

346413

@@ -391,20 +458,19 @@ asConstraint :: Parse PackageError P.Constraint

391458asConstraint = (,) <$> nth 0 asQualifiedProperName

392459 <*> nth 1 (eachInArray asType)

393460

394−asQualifiedProperName :: Parse e (P.Qualified P.ProperName)

461+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

395462asQualifiedProperName = fromAesonParser

396463

464+asQualifiedIdent :: Parse e (P.Qualified P.Ident)

465+asQualifiedIdent = fromAesonParser

466+

397467asBookmarks :: Parse BowerError [Bookmark]

398468asBookmarks = eachInArray asBookmark

399469

400470asBookmark :: Parse BowerError Bookmark

401471asBookmark =

402− build <$> key "package" (perhaps (withString parsePackageName))

403− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

404− <*> nth 1 asString)

405− where

406− build Nothing = Local

407− build (Just pn) = FromDep pn

472+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

473+ <*> nth 1 asString)

408474

409475asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

410476asResolvedDependencies =

@@ -449,7 +515,12 @@ instance A.ToJSON Module where

449515 A.object [ "name" .= modName

450516 , "comments" .= modComments

451517 , "declarations" .= modDeclarations

518+ , "reExports" .= map toObj modReExports

452519 ]

520+ where

521+ toObj (mn, decls) = A.object [ "moduleName" .= mn

522+ , "declarations" .= decls

523+ ]

453524

454525instance A.ToJSON Declaration where

455526 toJSON Declaration{..} =

@@ -478,6 +549,7 @@ instance A.ToJSON DeclarationInfo where

478549 ExternDataDeclaration kind -> ["kind" .= kind]

479550 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

480551 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

552+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]

481553

482554instance A.ToJSON ChildDeclarationInfo where

483555 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

src/Language/PureScript/Environment.hs+16−30

@@ -1,24 +1,8 @@

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

2−--

3−-- Module : Language.PureScript.Environment

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE OverloadedStrings #-}

172{-# LANGUAGE TemplateHaskell #-}

183

194module Language.PureScript.Environment where

205

21−import Data.Data

226import Data.Maybe (fromMaybe)

237import Data.Aeson.TH

248import qualified Data.Map as M

@@ -43,23 +27,23 @@ data Environment = Environment {

4327 -- |

4428 -- Type names currently in scope

4529 --

46− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)

30+ , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

4731 -- |

4832 -- Data constructors currently in scope, along with their associated type

4933 -- constructor name, argument types and return type.

50− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

34+ , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

5135 -- |

5236 -- Type synonyms currently in scope

5337 --

54− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)

38+ , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)

5539 -- |

5640 -- Available type class dictionaries

5741 --

58− , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

42+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

5943 -- |

6044 -- Type classes

6145 --

62− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

46+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

6347 } deriving (Show, Read)

6448

6549-- |

@@ -98,7 +82,8 @@ data NameKind

9882 -- |

9983 -- A name for member introduced by foreign import

10084 --

101− | External deriving (Show, Read, Eq, Data, Typeable)

85+ | External

86+ deriving (Show, Read, Eq)

10287

10388-- |

10489-- The kinds of a type

@@ -107,7 +92,7 @@ data TypeKind

10792 -- |

10893 -- Data type

10994 --

110− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]

95+ = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

11196 -- |

11297 -- Type synonym

11398 --

@@ -124,7 +109,7 @@ data TypeKind

124109 -- A scoped type variable

125110 --

126111 | ScopedTypeVar

127− deriving (Show, Read, Eq, Data, Typeable)

112+ deriving (Show, Read, Eq)

128113

129114-- |

130115-- The type ('data' or 'newtype') of a data type declaration

@@ -137,7 +122,8 @@ data DataDeclType

137122 -- |

138123 -- A newtype constructor

139124 --

140− | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)

125+ | Newtype

126+ deriving (Show, Read, Eq, Ord)

141127

142128showDataDeclType :: DataDeclType -> String

143129showDataDeclType Data = "data"

@@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where

156142-- |

157143-- Construct a ProperName in the Prim module

158144--

159−primName :: String -> Qualified ProperName

145+primName :: String -> Qualified (ProperName a)

160146primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

161147

162148-- |

@@ -240,7 +226,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)

240226-- associated kinds. There is also a pseudo `Partial` type that corresponds to

241227-- the class with the same name.

242228--

243−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

229+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

244230primTypes =

245231 M.fromList

246232 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

@@ -258,7 +244,7 @@ primTypes =

258244-- The primitive class map. This just contains to `Partial` class, used as a

259245-- kind of magic constraint for partial functions.

260246--

261−primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

247+primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

262248primClasses =

263249 M.fromList

264250 [ (primName "Partial", ([], [], [])) ]

@@ -266,14 +252,14 @@ primClasses =

266252-- |

267253-- Finds information about data constructors from the current environment.

268254--

269−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

255+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])

270256lookupConstructor env ctor =

271257 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

272258

273259-- |

274260-- Checks whether a data constructor is for a newtype.

275261--

276−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

262+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool

277263isNewtypeConstructor e ctor = case lookupConstructor e ctor of

278264 (Newtype, _, _, _) -> True

279265 (Data, _, _, _) -> False

src/Language/PureScript/Errors.hs+172−87

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

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

22{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE RecordWildCards #-}

43{-# LANGUAGE MultiParamTypeClasses #-}

65module Language.PureScript.Errors where

@@ -9,6 +8,7 @@ import Prelude ()

98import Prelude.Compat

109

1110import Data.Ord (comparing)

11+import Data.Char (isSpace)

1212import Data.Either (lefts, rights)

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

1414import Data.Foldable (fold)

@@ -53,63 +53,63 @@ data SimpleErrorMessage

5353 | RedefinedIdent Ident

5454 | OverlappingNamesInLet

5555 | UnknownModule ModuleName

56− | UnknownType (Qualified ProperName)

57− | UnknownTypeClass (Qualified ProperName)

56+ | UnknownType (Qualified (ProperName 'TypeName))

57+ | UnknownTypeClass (Qualified (ProperName 'ClassName))

5858 | UnknownValue (Qualified Ident)

59− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

60− | UnknownTypeConstructor (Qualified ProperName)

61− | UnknownImportType ModuleName ProperName

62− | UnknownExportType ProperName

63− | UnknownImportTypeClass ModuleName ProperName

64− | UnknownExportTypeClass ProperName

59+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

60+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

61+ | UnknownImportType ModuleName (ProperName 'TypeName)

62+ | UnknownExportType (ProperName 'TypeName)

63+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

64+ | UnknownExportTypeClass (ProperName 'ClassName)

6565 | UnknownImportValue ModuleName Ident

6666 | UnknownExportValue Ident

6767 | UnknownExportModule ModuleName

68− | UnknownImportDataConstructor ModuleName ProperName ProperName

69− | UnknownExportDataConstructor ProperName ProperName

68+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

69+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

7070 | ScopeConflict String [ModuleName]

71− | ConflictingTypeDecls ProperName

72− | ConflictingCtorDecls ProperName

73− | TypeConflictsWithClass ProperName

74− | CtorConflictsWithClass ProperName

75− | ClassConflictsWithType ProperName

76− | ClassConflictsWithCtor ProperName

71+ | ConflictingTypeDecls (ProperName 'TypeName)

72+ | ConflictingCtorDecls (ProperName 'ConstructorName)

73+ | TypeConflictsWithClass (ProperName 'TypeName)

74+ | CtorConflictsWithClass (ProperName 'ConstructorName)

75+ | ClassConflictsWithType (ProperName 'ClassName)

76+ | ClassConflictsWithCtor (ProperName 'ClassName)

7777 | DuplicateModuleName ModuleName

78− | DuplicateClassExport ProperName

78+ | DuplicateClassExport (ProperName 'ClassName)

7979 | DuplicateValueExport Ident

8080 | DuplicateTypeArgument String

8181 | InvalidDoBind

8282 | InvalidDoLet

8383 | CycleInDeclaration Ident

84− | CycleInTypeSynonym (Maybe ProperName)

84+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

8585 | CycleInModules [ModuleName]

8686 | NameIsUndefined Ident

87− | UndefinedTypeVariable ProperName

88− | PartiallyAppliedSynonym (Qualified ProperName)

87+ | UndefinedTypeVariable (ProperName 'TypeName)

88+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

8989 | EscapedSkolem (Maybe Expr)

9090 | TypesDoNotUnify Type Type

9191 | KindsDoNotUnify Kind Kind

9292 | ConstrainedTypeUnified Type Type

93− | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]

94− | NoInstanceFound (Qualified ProperName) [Type]

95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]

96− | CannotDerive (Qualified ProperName) [Type]

97− | CannotFindDerivingType ProperName

93+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

94+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]

95+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

96+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

97+ | CannotFindDerivingType (ProperName 'TypeName)

9898 | DuplicateLabel String (Maybe Expr)

9999 | DuplicateValueDeclaration Ident

100100 | ArgListLengthsDiffer Ident

101101 | OverlappingArgNames (Maybe Ident)

102102 | MissingClassMember Ident

103− | ExtraneousClassMember Ident (Qualified ProperName)

103+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

104104 | ExpectedType Type Kind

105− | IncorrectConstructorArity (Qualified ProperName)

105+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

106106 | ExprDoesNotHaveType Expr Type

107107 | PropertyIsMissing String

108108 | AdditionalProperty String

109109 | CannotApplyFunction Type Expr

110110 | TypeSynonymInstance

111− | OrphanInstance Ident (Qualified ProperName) [Type]

112− | InvalidNewtype ProperName

111+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

112+ | InvalidNewtype (ProperName 'TypeName)

113113 | InvalidInstanceHead Type

114114 | TransitiveExportError DeclarationRef [DeclarationRef]

115115 | ShadowedName Ident

@@ -120,17 +120,17 @@ data SimpleErrorMessage

120120 | NotExhaustivePattern [[Binder]] Bool

121121 | OverlappingPattern [[Binder]] Bool

122122 | IncompleteExhaustivityCheck

123− | ClassOperator ProperName Ident

124− | MisleadingEmptyTypeImport ModuleName ProperName

123+ | ClassOperator (ProperName 'ClassName) Ident

124+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

125125 | ImportHidingModule ModuleName

126126 | UnusedImport ModuleName

127− | UnusedExplicitImport ModuleName [String]

128− | UnusedDctorImport ProperName

129− | UnusedDctorExplicitImport ProperName [ProperName]

127+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

128+ | UnusedDctorImport (ProperName 'TypeName)

129+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130130 | DeprecatedOperatorDecl String

131131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132− | DeprecatedClassImport ModuleName ProperName

133− | DeprecatedClassExport ProperName

132+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133+ | DeprecatedClassExport (ProperName 'ClassName)

134134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135135 | DuplicateSelectiveImport ModuleName

136136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

@@ -138,7 +138,9 @@ data SimpleErrorMessage

138138 | DuplicateExportRef String

139139 | IntOutOfRange Integer String Integer Integer

140140 | RedundantEmptyHidingImport ModuleName

141+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

141142 | ImplicitImport ModuleName [DeclarationRef]

143+ | HidingImport ModuleName [DeclarationRef]

142144 | CaseBinderLengthDiffers Int [Binder]

143145 deriving (Show)

144146

@@ -147,7 +149,7 @@ data ErrorMessageHint

147149 = ErrorUnifyingTypes Type Type

148150 | ErrorInExpression Expr

149151 | ErrorInModule ModuleName

150− | ErrorInInstance (Qualified ProperName) [Type]

152+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

151153 | ErrorInSubsumption Type Type

152154 | ErrorCheckingAccessor Expr String

153155 | ErrorCheckingType Expr Type

@@ -155,11 +157,11 @@ data ErrorMessageHint

155157 | ErrorCheckingGuard

156158 | ErrorInferringType Expr

157159 | ErrorInApplication Expr Type Expr

158− | ErrorInDataConstructor ProperName

159− | ErrorInTypeConstructor ProperName

160+ | ErrorInDataConstructor (ProperName 'ConstructorName)

161+ | ErrorInTypeConstructor (ProperName 'TypeName)

160162 | ErrorInBindingGroup [Ident]

161163 | ErrorInDataBindingGroup

162− | ErrorInTypeSynonym ProperName

164+ | ErrorInTypeSynonym (ProperName 'TypeName)

163165 | ErrorInValueDeclaration Ident

164166 | ErrorInTypeDeclaration Ident

165167 | ErrorInForeignImport Ident

@@ -177,6 +179,8 @@ data HintCategory

177179

178180data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

179181

182+newtype ErrorSuggestion = ErrorSuggestion String

183+

180184-- | Get the source span for an error

181185errorSpan :: ErrorMessage -> Maybe SourceSpan

182186errorSpan = findHint matchSpan

@@ -309,7 +313,9 @@ errorCode em = case unwrapErrorMessage em of

309313 DuplicateExportRef{} -> "DuplicateExportRef"

310314 IntOutOfRange{} -> "IntOutOfRange"

311315 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

316+ ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

312317 ImplicitImport{} -> "ImplicitImport"

318+ HidingImport{} -> "HidingImport"

313319 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

314320

315321-- |

@@ -412,11 +418,48 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

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

413419 gHint other = pure other

414420

421+wikiUri :: ErrorMessage -> String

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

423+

424+-- TODO Other possible suggestions:

425+-- WildcardInferredType - source span not small enough

426+-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

427+-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span?

428+errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

429+errorSuggestion err = case err of

430+ UnusedImport{} -> emptySuggestion

431+ RedundantEmptyHidingImport{} -> emptySuggestion

432+ DuplicateImport{} -> emptySuggestion

433+ RedundantUnqualifiedImport{} -> emptySuggestion

434+ DeprecatedQualifiedSyntax name qualName -> suggest $

435+ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

436+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

437+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

438+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

439+ _ -> Nothing

440+

441+ where

442+ emptySuggestion = Just $ ErrorSuggestion ""

443+ suggest = Just . ErrorSuggestion

444+

445+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String

446+ importSuggestion mn refs qual =

447+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual

448+

449+ qstr :: Maybe ModuleName -> String

450+ qstr (Just mn) = " as " ++ runModuleName mn

451+ qstr Nothing = ""

452+

453+showSuggestion :: SimpleErrorMessage -> String

454+showSuggestion suggestion = case errorSuggestion suggestion of

455+ Just (ErrorSuggestion x) -> x

456+ _ -> ""

457+

415458-- |

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

417460--

418−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> Box.Box

419−prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

461+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box

462+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do

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

421464 um <- get

422465 return (prettyPrintErrorMessage um em)

@@ -425,20 +468,19 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

425468 -- Pretty print an ErrorMessage

426469 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

427470 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

428− paras

471+ paras $

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

430− , Box.moveDown 1 typeInformation

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

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

433− ]

473+ ] ++

474+ maybe [] (return . Box.moveDown 1) typeInformation ++

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

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

477+ ]

478+ | showWiki

434479 ]

435480 where

436− wikiUri :: String

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

438−

439− typeInformation :: Box.Box

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

441− | otherwise = Box.emptyBox 0 0

481+ typeInformation :: Maybe Box.Box

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

483+ | otherwise = Nothing

442484 where

443485 types :: [Box.Box]

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

@@ -790,9 +832,11 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

790832 renderSimpleErrorMessage (UnusedImport name) =

791833 line $ "The import of module " ++ runModuleName name ++ " is redundant"

792834

793− renderSimpleErrorMessage (UnusedExplicitImport name names) =

794− paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"

795− , indent $ paras $ map line names ]

835+ renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

836+ paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

837+ , indent $ paras $ map line names

838+ , line $ "It could be replaced with:"

839+ , indent $ line $ showSuggestion msg ]

796840

797841 renderSimpleErrorMessage (UnusedDctorImport name) =

798842 line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"

@@ -854,8 +898,19 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

854898 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

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

856900

857− renderSimpleErrorMessage (ImplicitImport mn refs) =

901+ renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

902+ paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."

903+ , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"

904+ , indent $ line $ showSuggestion msg

905+ ]

906+

907+ renderSimpleErrorMessage msg@(ImplicitImport mn _) =

858908 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "

909+ , indent $ line $ showSuggestion msg

910+ ]

911+

912+ renderSimpleErrorMessage (HidingImport mn refs) =

913+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "

859914 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

860915 ]

861916

@@ -992,37 +1047,13 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

9921047 paras :: [Box.Box] -> Box.Box

9931048 paras = Box.vcat Box.left

9941049

995− -- Pretty print and export declaration

996− prettyPrintExport :: DeclarationRef -> String

997− prettyPrintExport (TypeRef pn _) = runProperName pn

998− prettyPrintExport ref = prettyPrintRef ref

999−

1000− prettyPrintRef :: DeclarationRef -> String

1001− prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1002− prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

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

1004− prettyPrintRef (ValueRef ident) = showIdent ident

1005− prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1006− prettyPrintRef (ProperRef pn) = runProperName pn

1007− prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1008− prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

1009− prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

1010−

1011− prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1012− prettyPrintImport mn idt qual =

1013− let i = case idt of

1014− Implicit -> runModuleName mn

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

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

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

1018−

10191050 -- | Simplify an error message

10201051 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

10211052 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

10221053 where

10231054 -- Take the last instance of each "hint category"

10241055 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

1025− simplifyHints = reverse . nubBy categoriesEqual . reverse

1056+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse

10261057

10271058 -- Don't remove hints in the "other" category

10281059 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

@@ -1032,6 +1063,30 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

10321063 (_, OtherHint) -> False

10331064 (c1, c2) -> c1 == c2

10341065

1066+ -- | See https://github.com/purescript/purescript/issues/1802

1067+ stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]

1068+ stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint

1069+ where

1070+ isApplicationHint ErrorInApplication{} = True

1071+ isApplicationHint _ = False

1072+ stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint

1073+ where

1074+ isCheckHint ErrorCheckingType{} = True

1075+ isCheckHint _ = False

1076+ stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint

1077+ where

1078+ isUnifyHint ErrorUnifyingTypes{} = True

1079+ isUnifyHint _ = False

1080+ stripRedudantHints _ = id

1081+

1082+ stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]

1083+ stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs

1084+ stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs

1085+ stripFirst p (hint : hs)

1086+ | p hint = hs

1087+ | otherwise = hint : hs

1088+ stripFirst _ [] = []

1089+

10351090 hintCategory :: ErrorMessageHint -> HintCategory

10361091 hintCategory ErrorCheckingType{} = ExprHint

10371092 hintCategory ErrorInferringType{} = ExprHint

@@ -1043,6 +1098,30 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

10431098 hintCategory PositionedError{} = PositionHint

10441099 hintCategory _ = OtherHint

10451100

1101+-- Pretty print and export declaration

1102+prettyPrintExport :: DeclarationRef -> String

1103+prettyPrintExport (TypeRef pn _) = runProperName pn

1104+prettyPrintExport ref = prettyPrintRef ref

1105+

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

1107+prettyPrintImport mn idt qual =

1108+ let i = case idt of

1109+ Implicit -> runModuleName mn

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

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

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

1113+

1114+prettyPrintRef :: DeclarationRef -> String

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

1116+prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

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

1118+prettyPrintRef (ValueRef ident) = showIdent ident

1119+prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1120+prettyPrintRef (ProperRef name) = name

1121+prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

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

1124+

10461125-- |

10471126-- Pretty print multiple errors

10481127--

@@ -1065,12 +1144,12 @@ prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error f

10651144

10661145prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box

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

1068− let result = prettyPrintSingleError full level e

1147+ let result = prettyPrintSingleError full level True e

10691148 in Box.vcat Box.left [ Box.text intro

10701149 , result

10711150 ]

10721151prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1073− let result = map (prettyPrintSingleError full level) es

1152+ let result = map (prettyPrintSingleError full level True) es

10741153 in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

10751154 where

10761155 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

@@ -1133,9 +1212,15 @@ line :: String -> Box.Box

11331212line = Box.text

11341213

11351214renderBox :: Box.Box -> String

1136−renderBox = unlines . map trimEnd . lines . Box.render

1215+renderBox = unlines

1216+ . map (dropWhileEnd isSpace)

1217+ . dropWhile whiteSpace

1218+ . dropWhileEnd whiteSpace

1219+ . lines

1220+ . Box.render

11371221 where

1138− trimEnd = reverse . dropWhile (== ' ') . reverse

1222+ dropWhileEnd p = reverse . dropWhile p . reverse

1223+ whiteSpace = all isSpace

11391224

11401225-- |

11411226-- Rethrow an error with a more detailed error message in the case of failure

src/Language/PureScript/Externs.hs+12−12

@@ -73,28 +73,28 @@ data ExternsFixity = ExternsFixity

7373 -- | The operator symbol

7474 , efOperator :: String

7575 -- | The value the operator is an alias for

76− , efAlias :: Maybe Ident

76+ , efAlias :: Maybe (Qualified Ident)

7777 } deriving (Show, Read)

7878

7979-- | A type or value declaration appearing in an externs file

8080data ExternsDeclaration =

8181 -- | A type declaration

8282 EDType

83− { edTypeName :: ProperName

83+ { edTypeName :: ProperName 'TypeName

8484 , edTypeKind :: Kind

8585 , edTypeDeclarationKind :: TypeKind

8686 }

8787 -- | A type synonym

8888 | EDTypeSynonym

89− { edTypeSynonymName :: ProperName

89+ { edTypeSynonymName :: ProperName 'TypeName

9090 , edTypeSynonymArguments :: [(String, Maybe Kind)]

9191 , edTypeSynonymType :: Type

9292 }

9393 -- | A data construtor

9494 | EDDataConstructor

95− { edDataCtorName :: ProperName

95+ { edDataCtorName :: ProperName 'ConstructorName

9696 , edDataCtorOrigin :: DataDeclType

97− , edDataCtorTypeCtor :: ProperName

97+ , edDataCtorTypeCtor :: ProperName 'TypeName

9898 , edDataCtorType :: Type

9999 , edDataCtorFields :: [Ident]

100100 }

@@ -105,14 +105,14 @@ data ExternsDeclaration =

105105 }

106106 -- | A type class declaration

107107 | EDClass

108− { edClassName :: ProperName

108+ { edClassName :: ProperName 'ClassName

109109 , edClassTypeArguments :: [(String, Maybe Kind)]

110110 , edClassMembers :: [(Ident, Type)]

111111 , edClassConstraints :: [Constraint]

112112 }

113113 -- | An instance declaration

114114 | EDInstance

115− { edInstanceClassName :: Qualified ProperName

115+ { edInstanceClassName :: Qualified (ProperName 'ClassName)

116116 , edInstanceName :: Ident

117117 , edInstanceTypes :: [Type]

118118 , edInstanceConstraints :: Maybe [Constraint]

@@ -178,7 +178,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

178178 Just (kind, tk@(DataType _ tys)) ->

179179 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

180180 | dctor <- fromMaybe (map fst tys) dctors

181− , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

181+ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)

182182 ]

183183 _ -> internalError "toExternsDeclaration: Invalid input"

184184 toExternsDeclaration (ValueRef ident)

@@ -186,10 +186,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

186186 = [ EDValue ident ty ]

187187 toExternsDeclaration (TypeClassRef className)

188188 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

189− , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)

190− , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env

191− = [ EDType className kind TypeSynonym

192− , EDTypeSynonym className args synTy

189+ , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env

190+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env

191+ = [ EDType (coerceProperName className) kind TypeSynonym

192+ , EDTypeSynonym (coerceProperName className) args synTy

193193 , EDClass className args members implies

194194 ]

195195 toExternsDeclaration (TypeInstanceRef ident)

src/Language/PureScript/Kinds.hs+2−17

@@ -1,18 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.Kinds

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

161{-# LANGUAGE TemplateHaskell #-}

172

183module Language.PureScript.Kinds where

@@ -20,7 +5,6 @@ module Language.PureScript.Kinds where

205import Prelude ()

216import Prelude.Compat

227

23−import Data.Data

248import qualified Data.Aeson.TH as A

259

2610-- |

@@ -46,7 +30,8 @@ data Kind

4630 -- |

4731 -- Function kinds

4832 --

49− | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)

33+ | FunKind Kind Kind

34+ deriving (Show, Read, Eq, Ord)

5035

5136$(A.deriveJSON A.defaultOptions ''Kind)

5237

src/Language/PureScript/Linter/Exhaustive.hs+28−39

@@ -1,24 +1,12 @@

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

2−--

3−-- Module : Language.PureScript.Exhaustive

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- | Module for exhaustivity checking over pattern matching definitions

13−-- | The algorithm analyses the clauses of a definition one by one from top

14−-- | to bottom, where in each step it has the cases already missing (uncovered),

15−-- | and it generates the new set of missing cases.

16−--

17−-----------------------------------------------------------------------------

18−

191{-# LANGUAGE FlexibleContexts #-}

202{-# LANGUAGE ScopedTypeVariables #-}

213

4+-- |

5+-- Module for exhaustivity checking over pattern matching definitions

6+-- The algorithm analyses the clauses of a definition one by one from top

7+-- to bottom, where in each step it has the cases already missing (uncovered),

8+-- and it generates the new set of missing cases.

9+--

2210module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

2311

2412import Prelude ()

@@ -54,7 +42,11 @@ data RedudancyError = Incomplete | Unknown

5442-- |

5543-- Qualifies a propername from a given qualified propername and a default module name

5644--

57−qualifyName :: a -> ModuleName -> Qualified a -> Qualified a

45+qualifyName

46+ :: (ProperName a)

47+ -> ModuleName

48+ -> Qualified (ProperName b)

49+ -> Qualified (ProperName a)

5850qualifyName n defmn qn = Qualified (Just mn) n

5951 where

6052 (mn, _) = qualify defmn qn

@@ -65,31 +57,28 @@ qualifyName n defmn qn = Qualified (Just mn) n

6557-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

6658-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

6759--

68−getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

60+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]

6961getConstructors env defmn n = extractConstructors lnte

7062 where

71− qpn :: Qualified ProperName

72− qpn = getConsDataName n

7363

74− getConsDataName :: Qualified ProperName -> Qualified ProperName

75− getConsDataName con = qualifyName nm defmn con

76− where

77− nm = case getConsInfo con of

78− Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

79− Just (_, pm, _, _) -> pm

80−

81− getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])

82− getConsInfo con = M.lookup con dce

83− where

84− dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

85− dce = dataConstructors env

64+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]

65+ extractConstructors (Just (_, DataType _ pt)) = pt

66+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

8667

8768 lnte :: Maybe (Kind, TypeKind)

8869 lnte = M.lookup qpn (types env)

8970

90− extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

91− extractConstructors (Just (_, DataType _ pt)) = pt

92− extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

71+ qpn :: Qualified (ProperName 'TypeName)

72+ qpn = getConsDataName n

73+

74+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

75+ getConsDataName con =

76+ case getConsInfo con of

77+ Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

78+ Just (_, pm, _, _) -> qualifyName pm defmn con

79+

80+ getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])

81+ getConsInfo con = M.lookup con (dataConstructors env)

9382

9483-- |

9584-- Replicates a wildcard binder

@@ -303,14 +292,14 @@ checkExhaustiveDecls env mn = mapM_ onDecl

303292 hasPartialConstraint :: Type -> Bool

304293 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

305294 where

306− go :: Qualified ProperName -> Bool

295+ go :: Qualified (ProperName 'ClassName) -> Bool

307296 go qname

308297 | qname == partialClass = True

309298 | otherwise =

310299 case qname `M.lookup` typeClasses env of

311300 Just ([], _, cs') -> any (go . fst) cs'

312301 _ -> False

313− partialClass :: Qualified ProperName

302+ partialClass :: Qualified (ProperName 'ClassName)

314303 partialClass = primName "Partial"

315304 hasPartialConstraint _ = False

316305

src/Language/PureScript/Linter/Imports.hs+242−89

@@ -1,18 +1,23 @@

11{-# LANGUAGE ScopedTypeVariables #-}

22{-# LANGUAGE FlexibleContexts #-}

4−module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where

4+module Language.PureScript.Linter.Imports

5+ ( lintImports

6+ , Name(..)

7+ , UsedImports()

8+ ) where

610import Prelude ()

711import Prelude.Compat

812

9−import qualified Data.Map as M

10−import Data.Maybe (mapMaybe, isNothing)

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

13+import Control.Monad (unless, when)

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

1315import Control.Monad.Writer.Class

14−import Control.Monad (unless,when)

16+

1517import Data.Foldable (forM_)

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

19+import Data.Maybe (mapMaybe)

20+import qualified Data.Map as M

1621

1722import Language.PureScript.AST.Declarations

1823import Language.PureScript.AST.SourcePos

@@ -28,125 +33,271 @@ import qualified Language.PureScript.Constants as C

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

2934data Name

3035 = IdentName (Qualified Ident)

31− | TypeName (Qualified ProperName)

32− | DctorName (Qualified ProperName)

33− | ClassName (Qualified ProperName)

34− deriving (Eq)

36+ | TyName (Qualified (ProperName 'TypeName))

37+ | DctorName (Qualified (ProperName 'ConstructorName))

38+ | TyClassName (Qualified (ProperName 'ClassName))

39+ deriving (Eq, Show)

3540

36−getIdentName :: Name -> Maybe Ident

37−getIdentName (IdentName (Qualified _ name)) = Just name

38−getIdentName _ = Nothing

41+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident

42+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

43+getIdentName _ _ = Nothing

3944

40−getTypeName :: Name -> Maybe ProperName

41−getTypeName (TypeName (Qualified _ name)) = Just name

42−getTypeName _ = Nothing

45+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

46+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

47+getTypeName _ _ = Nothing

4348

44−getClassName :: Name -> Maybe ProperName

45−getClassName (ClassName (Qualified _ name)) = Just name

46−getClassName _ = Nothing

49+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)

50+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name

51+getClassName _ _ = Nothing

4752

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

4954type UsedImports = M.Map ModuleName [Name]

5055

5156-- |

52−-- Find and warn on any unused import statements (qualified or unqualified)

53−-- or references in an explicit import list.

57+-- Find and warn on:

58+--

59+-- * Unused import statements (qualified or unqualified)

60+--

61+-- * Unused references in an explicit import list

5462--

55−findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()

56−findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

57− imps <- findImports mdecls

58− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

59− forM_ decls $ \(ss, declType, qualifierName) ->

60− censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

61− let names = nub $ M.findWithDefault [] mni usedImps

62− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

63− usedDctors = mapMaybe (matchDctor qualifierName) names

64− in case declType of

65− Implicit | isNothing qualifierName ->

66− let classRefs = TypeClassRef <$> mapMaybe getClassName names

67− valueRefs = ValueRef <$> mapMaybe getIdentName names

68− types = mapMaybe getTypeName names

69− typesWithDctors = reconstructTypeRefs mni usedDctors

70− typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

71− typesRefs

72− = map (flip TypeRef (Just [])) typesWithoutDctors

73− ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

74− in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs)

75− Explicit declrefs -> do

76− let idents = nub (mapMaybe runDeclRef declrefs)

77− let diff = idents \\ usedNames

78− case (length diff, length idents) of

79− (0, _) -> return ()

80− (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni

81− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff

82−

83− -- If we've not already warned a type is unused, check its data constructors

84− forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

85− let allCtors = dctorsForType mni tn

86− when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of

87− (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn

88− (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn

89− (Just ctors, _) ->

90− let ddiff = ctors \\ usedDctors

91− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

92− _ -> return ()

93−

94− return ()

95−

96− _ -> return ()

63+-- * Implicit imports of modules

64+--

65+-- * Implicit imports into a virtual module (unless the virtual module only has

66+-- members from one module imported)

67+--

68+-- * Imports using `hiding` (this is another form of implicit importing)

69+--

70+lintImports

71+ :: forall m

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

73+ => Module

74+ -> Env

75+ -> UsedImports

76+ -> m ()

77+lintImports (Module _ _ mn mdecls mexports) env usedImps = do

78+

79+ let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)

80+ usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

81+

82+ imps <- M.toAscList <$> findImports mdecls

83+

84+ forM_ imps $ \(mni, decls) ->

85+ unless (isPrim mni) $ do

86+ forM_ decls $ \(ss, declType, qualifierName) ->

87+ censor (onErrorMessages $ addModuleLocError ss) $ do

88+ let names = nub $ M.findWithDefault [] mni usedImps'

89+ lintImportDecl env mni qualifierName names declType

90+

91+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do

92+ let mnis = nub $ map (\(_, _, mni) -> mni) entries

93+ unless (length mnis == 1) $ do

94+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

95+ forM_ implicits $ \(ss, _, mni) ->

96+ censor (onErrorMessages $ addModuleLocError ss) $ do

97+ let names = nub $ M.findWithDefault [] mni usedImps'

98+ usedRefs = findUsedRefs env mni (Just mnq) names

99+ unless (null usedRefs) $

100+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

101+

102+ return ()

103+

97104 where

98− reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]

99− reconstructTypeRefs mni = foldr accumDctors M.empty

100− where

101− accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

102105

103− findTypeForDctor :: ModuleName -> ProperName -> ProperName

104− findTypeForDctor mn dctor =

105− case mn `M.lookup` env of

106− Just (_, _, exps) ->

107− case find (elem dctor . snd . fst) (exportedTypes exps) of

108− Just ((ty, _), _) -> ty

109− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

110− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

106+ -- Checks whether a module is the Prim module - used to suppress any checks

107+ -- made, as Prim is always implicitly imported.

108+ isPrim :: ModuleName -> Bool

109+ isPrim = (== ModuleName [ProperName C.prim])

110+

111+ -- Creates a map of virtual modules mapped to all the declarations that

112+ -- import to that module, with the corresponding source span, import type,

113+ -- and module being imported

114+ byQual

115+ :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]

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

117+ byQual = foldr goImp M.empty

118+ where

119+ goImp (mni, xs) acc = foldr (goDecl mni) acc xs

120+ goDecl mni (ss, declType, Just qmn) acc =

121+ let entry = (ss, declType, mni)

122+ in M.alter (Just . maybe [entry] (entry :)) qmn acc

123+ goDecl _ _ acc = acc

111124

112− -- rely on exports being elaborated by this point

113− alwaysUsedModules :: [ ModuleName ]

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

125+ -- The list of modules that are being re-exported by the current module. Any

126+ -- module that appears in this list is always considered to be used.

127+ exportedModules :: [ModuleName]

128+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports

115129 where

116130 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

117− extractModule (ModuleRef mn) = Just mn

131+ extractModule (ModuleRef mne) = Just mne

118132 extractModule _ = Nothing

119133

120− qnameUsed :: Maybe ModuleName -> Bool

121− qnameUsed (Just qn) = qn `elem` alwaysUsedModules

122− qnameUsed Nothing = False

134+ -- Elaborates the UsedImports to include values from modules that are being

135+ -- re-exported. This ensures explicit export hints are printed for modules

136+ -- that are implicitly exported and then re-exported.

137+ elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

138+ elaborateUsed scope mne used =

139+ let classes = extractByQual mne (importedTypeClasses scope) TyClassName

140+ types = extractByQual mne (importedTypes scope) TyName

141+ dctors = extractByQual mne (importedDataConstructors scope) DctorName

142+ values = extractByQual mne (importedValues scope) IdentName

143+ in foldr go used (classes ++ types ++ dctors ++ values)

144+ where

145+ go :: (ModuleName, Name) -> UsedImports -> UsedImports

146+ go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc

147+

148+ extractByQual

149+ :: (Eq a)

150+ => ModuleName

151+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

152+ -> (Qualified a -> Name)

153+ -> [(ModuleName, Name)]

154+ extractByQual k m toName = mapMaybe go (M.toList m)

155+ where

156+ go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =

157+ case fst (head is) of

158+ Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)

159+ _ -> internalError "unqualified name in extractByQual"

160+ go _ = Nothing

161+

162+lintImportDecl

163+ :: forall m

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

165+ => Env

166+ -> ModuleName

167+ -> Maybe ModuleName

168+ -> [Name]

169+ -> ImportDeclarationType

170+ -> m ()

171+lintImportDecl env mni qualifierName names declType =

172+ case declType of

173+ Implicit -> case qualifierName of

174+ Nothing -> checkImplicit ImplicitImport

175+ Just q ->

176+ let usedModuleNames = mapMaybe extractQualName names

177+ in unless (q `elem` usedModuleNames) unused

178+ Hiding _ -> checkImplicit HidingImport

179+ Explicit [] -> unused

180+ Explicit declrefs -> checkExplicit declrefs

181+

182+ where

123183

124− dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]

184+ checkImplicit

185+ :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)

186+ -> m ()

187+ checkImplicit warning =

188+ if null allRefs

189+ then unused

190+ else tell $ errorMessage $ warning mni allRefs

191+

192+ checkExplicit

193+ :: [DeclarationRef]

194+ -> m ()

195+ checkExplicit declrefs = do

196+ let idents = nub (mapMaybe runDeclRef declrefs)

197+ dctors = mapMaybe (matchDctor qualifierName) names

198+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

199+ diff = idents \\ usedNames

200+ case (length diff, length idents) of

201+ (0, _) -> return ()

202+ (n, m) | n == m -> unused

203+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs

204+

205+ -- If we've not already warned a type is unused, check its data constructors

206+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

207+ let allCtors = dctorsForType mni tn

208+ when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of

209+ (_, []) | c /= Just [] ->

210+ tell $ errorMessage $ UnusedDctorImport tn

211+ (Just ctors, dctors') ->

212+ let ddiff = ctors \\ dctors'

213+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

214+ _ -> return ()

215+ return ()

216+

217+ unused :: m ()

218+ unused = tell $ errorMessage $ UnusedImport mni

219+

220+ allRefs :: [DeclarationRef]

221+ allRefs = findUsedRefs env mni qualifierName names

222+

223+ dtys

224+ :: ModuleName

225+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

125226 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

126227

127− dctorsForType :: ModuleName -> ProperName -> [ProperName]

228+ dctorsForType

229+ :: ModuleName

230+ -> ProperName 'TypeName

231+ -> [ProperName 'ConstructorName]

128232 dctorsForType mn tn =

129233 maybe [] getDctors (find matches $ dtys mn)

130234 where

131235 matches ((ty, _),_) = ty == tn

132236 getDctors ((_,ctors),_) = ctors

133237

134− typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

238+ typeForDCtor

239+ :: ModuleName

240+ -> ProperName 'ConstructorName

241+ -> Maybe (ProperName 'TypeName)

135242 typeForDCtor mn pn =

136243 getTy <$> find matches (dtys mn)

137244 where

138245 matches ((_, ctors), _) = pn `elem` ctors

139246 getTy ((ty, _), _) = ty

140247

248+findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]

249+findUsedRefs env mni qualifierName names =

250+ let

251+ classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

252+ valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

253+ types = mapMaybe (getTypeName qualifierName) names

254+ dctors = mapMaybe (matchDctor qualifierName) names

255+ typesWithDctors = reconstructTypeRefs dctors

256+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

257+ typesRefs

258+ = map (flip TypeRef (Just [])) typesWithoutDctors

259+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

260+ in classRefs ++ typesRefs ++ valueRefs

261+

262+ where

263+

264+ reconstructTypeRefs

265+ :: [ProperName 'ConstructorName]

266+ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

267+ reconstructTypeRefs = foldr accumDctors M.empty

268+ where

269+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

141270

142−matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

271+ findTypeForDctor

272+ :: ModuleName

273+ -> ProperName 'ConstructorName

274+ -> ProperName 'TypeName

275+ findTypeForDctor mn dctor =

276+ case mn `M.lookup` env of

277+ Just (_, _, exps) ->

278+ case find (elem dctor . snd . fst) (exportedTypes exps) of

279+ Just ((ty, _), _) -> ty

280+ Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

281+ Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

282+

283+matchName

284+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

285+ -> Maybe ModuleName

286+ -> Name

287+ -> Maybe String

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

144−matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x

145−matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x

289+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

290+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

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

147292matchName _ _ _ = Nothing

148293

149−matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName

294+extractQualName :: Name -> Maybe ModuleName

295+extractQualName (IdentName (Qualified q _)) = q

296+extractQualName (TyName (Qualified q _)) = q

297+extractQualName (TyClassName (Qualified q _)) = q

298+extractQualName (DctorName (Qualified q _)) = q

299+

300+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)

150301matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

151302matchDctor _ _ = Nothing

152303

@@ -157,7 +308,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

157308runDeclRef (TypeClassRef pn) = Just $ runProperName pn

158309runDeclRef _ = Nothing

159310

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

311+getTypeRef

312+ :: DeclarationRef

313+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

161314getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

162315getTypeRef (TypeRef pn x) = Just (pn, x)

163316getTypeRef _ = Nothing

src/Language/PureScript/Make.hs−1

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

1−{-# LANGUAGE DataKinds #-}

21{-# LANGUAGE FlexibleContexts #-}

32{-# LANGUAGE GeneralizedNewtypeDeriving #-}

43{-# LANGUAGE TupleSections #-}

src/Language/PureScript/ModuleDependencies.hs+1

@@ -58,6 +58,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

5858 where

5959 forDecls :: Declaration -> [ModuleName]

6060 forDecls (ImportDeclaration mn _ _ _) = [mn]

61+ forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

6162 forDecls _ = []

6263

6364 forValues :: Expr -> [ModuleName]

src/Language/PureScript/Names.hs+46−26

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

1−{-# LANGUAGE DeriveDataTypeable #-}

21{-# LANGUAGE DeriveFunctor #-}

32{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE EmptyDataDecls #-}

4+{-# LANGUAGE KindSignatures #-}

66-- |

77-- Data types for names

@@ -12,11 +12,8 @@ import Control.Monad (liftM)

1212import Control.Monad.Supply.Class

1313

1414import Data.List

15−import Data.Data

16−import Data.List.Split (splitOn)

15+import Data.Aeson

1716import Data.Aeson.TH

18−import qualified Data.Aeson as A

19−import qualified Data.Text as T

2017

2118-- |

2219-- Names for value identifiers

@@ -33,7 +30,8 @@ data Ident

3330 -- |

3431 -- A generated name for an identifier

3532 --

36− | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)

33+ | GenIdent (Maybe String) Integer

34+ deriving (Show, Read, Eq, Ord)

3735

3836runIdent :: Ident -> String

3937runIdent (Ident i) = i

@@ -54,12 +52,33 @@ freshIdent' = liftM (GenIdent Nothing) fresh

5452-- |

5553-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

5654--

57−newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)

55+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }

56+ deriving (Show, Read, Eq, Ord)

57+

58+instance ToJSON (ProperName a) where

59+ toJSON = toJSON . runProperName

60+

61+instance FromJSON (ProperName a) where

62+ parseJSON = fmap ProperName . parseJSON

63+

64+-- |

65+-- The closed set of proper name types.

66+--

67+data ProperNameType = TypeName | ConstructorName | ClassName | Namespace

68+

69+-- |

70+-- Coerces a ProperName from one ProperNameType to another. This should be used

71+-- with care, and is primarily used to convert ClassNames into TypeNames after

72+-- classes have been desugared.

73+--

74+coerceProperName :: ProperName a -> ProperName b

75+coerceProperName = ProperName . runProperName

5876

5977-- |

6078-- Module names

6179--

62−newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)

80+newtype ModuleName = ModuleName [ProperName 'Namespace]

81+ deriving (Show, Read, Eq, Ord)

6382

6483runModuleName :: ModuleName -> String

6584runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

@@ -75,25 +94,13 @@ moduleNameFromString = ModuleName . splitProperNames

7594-- |

7695-- A qualified name, i.e. a name with an optional module name

7796--

78−data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)

97+data Qualified a = Qualified (Maybe ModuleName) a

98+ deriving (Show, Read, Eq, Ord, Functor)

7999

80100showQualified :: (a -> String) -> Qualified a -> String

81101showQualified f (Qualified Nothing a) = f a

82102showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

83103

84−instance (a ~ ProperName) => A.ToJSON (Qualified a) where

85− toJSON = A.toJSON . showQualified runProperName

86−

87−instance (a ~ ProperName) => A.FromJSON (Qualified a) where

88− parseJSON =

89− A.withText "Qualified ProperName" $ \str ->

90− return $ case reverse (splitOn "." (T.unpack str)) of

91− [name] -> Qualified Nothing (ProperName name)

92− (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)

93− _ -> Qualified Nothing (ProperName "")

94− where

95− reconstructModuleName = moduleNameFromString . intercalate "." . reverse

96−

97104-- |

98105-- Provide a default module name, if a name is unqualified

99106--

@@ -114,10 +121,23 @@ disqualify (Qualified _ a) = a

114121-- |

115122-- Checks whether a qualified value is actually qualified with a module reference

116123--

124+isQualified :: Qualified a -> Bool

125+isQualified (Qualified Nothing _) = False

126+isQualified _ = True

127+

128+-- |

129+-- Checks whether a qualified value is not actually qualified with a module reference

130+--

117131isUnqualified :: Qualified a -> Bool

118−isUnqualified (Qualified Nothing _) = True

119−isUnqualified _ = False

132+isUnqualified = not . isQualified

133+

134+-- |

135+-- Checks whether a qualified value is qualified with a particular module

136+--

137+isQualifiedWith :: ModuleName -> Qualified a -> Bool

138+isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'

139+isQualifiedWith _ _ = False

120140

141+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)

121142$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

122−$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)

123143$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

src/Language/PureScript/Parser/Common.hs+3−15

@@ -1,20 +1,8 @@

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

2−--

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

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

113-- |

124-- Constants, and utility functions to be used when parsing

135--

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

15−

16−{-# LANGUAGE FlexibleContexts #-}

17−

186module Language.PureScript.Parser.Common where

197

208import Control.Applicative

@@ -27,7 +15,7 @@ import Language.PureScript.Names

2715

2816import qualified Text.Parsec as P

2917

30−properName :: TokenParser ProperName

18+properName :: TokenParser (ProperName a)

3119properName = ProperName <$> uname

3220

3321-- |

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -122,7 +122,7 @@ parseFixityDeclaration :: TokenParser Declaration

122122parseFixityDeclaration = do

123123 fixity <- parseFixity

124124 indented

125− alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"

125+ alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"

126126 name <- symbol

127127 return $ FixityDeclaration fixity name alias

128128

@@ -165,7 +165,7 @@ parseDeclarationRef =

165165 parseProperRef = do

166166 name <- properName

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

168− return $ maybe (ProperRef name) (TypeRef name) dctors

168+ return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors

169169

170170parseTypeClassDeclaration :: TokenParser Declaration

171171parseTypeClassDeclaration = do

src/Language/PureScript/Pretty/Types.hs+10−22

@@ -1,26 +1,14 @@

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

2−--

3−-- Module : Language.PureScript.Pretty.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

111-- |

122-- Pretty printer for Types

133--

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

15−

16−module Language.PureScript.Pretty.Types (

17− typeAsBox,

18− prettyPrintType,

19− typeAtomAsBox,

20− prettyPrintTypeAtom,

21− prettyPrintRowWith,

22− prettyPrintRow

23−) where

4+module Language.PureScript.Pretty.Types

5+ ( typeAsBox

6+ , prettyPrintType

7+ , typeAtomAsBox

8+ , prettyPrintTypeAtom

9+ , prettyPrintRowWith

10+ , prettyPrintRow

11+ ) where

2412

2513import Data.Maybe (fromMaybe)

2614

@@ -50,11 +38,11 @@ typeLiterals = mkPattern match

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

5139 match _ = Nothing

5240

53−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

41+constraintsAsBox :: [Constraint] -> Box -> Box

5442constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

5543constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

5644

57−constraintAsBox :: Qualified ProperName -> [Type] -> Box

45+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box

5846constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

5947

6048-- |

src/Language/PureScript/Publish.hs+23−6

@@ -146,11 +146,20 @@ preparePackage' opts = do

146146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

147147getModulesAndBookmarks = do

148148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

149− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)

150− >>= either (userError . ParseAndDesugarError) return

149+ (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles

150+

151+ case runExcept (D.convertModulesInPackage env modules') of

152+ Right modules -> return (bookmarks, modules)

153+ Left err -> userError (CompileError err)

154+

151155 where

152− renderModules bookmarks modules =

153− return (bookmarks, map D.convertModule modules)

156+ parseAndDesugar inputFiles depsFiles = do

157+ r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles

158+ case r of

159+ Right r' ->

160+ return r'

161+ Left err ->

162+ userError (CompileError err)

154163

155164data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)

156165

@@ -196,8 +205,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract

196205 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)

197206

198207extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)

199−extractGithub =

200− stripPrefix "git://github.com/"

208+extractGithub = stripGitHubPrefixes

201209 >>> fmap (splitOn "/")

202210 >=> takeTwo

203211 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))

@@ -207,6 +215,15 @@ extractGithub =

207215 takeTwo [x, y] = Just (x, y)

208216 takeTwo _ = Nothing

209217

218+ stripGitHubPrefixes :: String -> Maybe String

219+ stripGitHubPrefixes = stripPrefixes [ "git://github.com/"

220+ , "https://github.com/"

221+ , "git@github.com:"

222+ ]

223+

224+ stripPrefixes :: [String] -> String -> Maybe String

225+ stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes

226+

210227 dropDotGit :: String -> String

211228 dropDotGit str

212229 | ".git" `isSuffixOf` str = take (length str - 4) str

src/Language/PureScript/Publish/ErrorsWarnings.hs+3−14

@@ -33,7 +33,6 @@ import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBower

3333import qualified Web.Bower.PackageMeta as Bower

3434

3535import qualified Language.PureScript as P

36−import qualified Language.PureScript.Docs as D

3736

3837import Language.PureScript.Publish.BoxesHelpers

3938

@@ -61,7 +60,7 @@ data UserError

6160 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

6261 | BadRepositoryField RepositoryFieldError

6362 | MissingDependencies (NonEmpty PackageName)

64− | ParseAndDesugarError D.ParseDesugarError

63+ | CompileError P.MultipleErrors

6564 | DirtyWorkingTree

6665 deriving (Show)

6766

@@ -188,19 +187,9 @@ displayUserError e = case e of

188187 [ "Please install ", them, " first, by running `bower install`."

189188 ])

190189 ]

191− ParseAndDesugarError (D.ParseError err) ->

190+ CompileError err ->

192191 vcat

193− [ para "Parse error:"

194− , indented (P.prettyPrintMultipleErrorsBox False err)

195− ]

196− ParseAndDesugarError (D.SortModulesError err) ->

197− vcat

198− [ para "Error in sortModules:"

199− , indented (P.prettyPrintMultipleErrorsBox False err)

200− ]

201− ParseAndDesugarError (D.DesugarError err) ->

202− vcat

203− [ para "Error while desugaring:"

192+ [ para "Compile error:"

204193 , indented (P.prettyPrintMultipleErrorsBox False err)

205194 ]

206195 DirtyWorkingTree ->

src/Language/PureScript/Sugar/BindingGroups.hs+73−55

@@ -1,60 +1,61 @@

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

2−--

3−-- Module : Language.PureScript.BindingGroups

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE LambdaCase #-}

115-- |

126-- This module implements the desugaring pass which creates binding groups from sets of

137-- mutually-recursive value declarations and mutually-recursive type declarations.

148--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20−module Language.PureScript.Sugar.BindingGroups (

21− createBindingGroups,

22− createBindingGroupsModule,

23− collapseBindingGroups,

24− collapseBindingGroupsModule

25−) where

9+module Language.PureScript.Sugar.BindingGroups

10+ ( createBindingGroups

11+ , createBindingGroupsModule

12+ , collapseBindingGroups

13+ , collapseBindingGroupsModule

14+ ) where

2615

2716import Prelude ()

2817import Prelude.Compat

2918

30−import Data.Graph

31−import Data.List (nub, intersect)

32−import Data.Maybe (isJust, mapMaybe)

3319import Control.Monad ((<=<))

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

3521

22+import Data.Graph

23+import Data.List (nub, intersect)

24+import Data.Maybe (isJust, mapMaybe)

3625import qualified Data.Set as S

3726

38−import Language.PureScript.Crash

3927import Language.PureScript.AST

40−import Language.PureScript.Names

41−import Language.PureScript.Types

28+import Language.PureScript.Crash

4229import Language.PureScript.Environment

4330import Language.PureScript.Errors

31+import Language.PureScript.Names

32+import Language.PureScript.Types

4433

4534-- |

4635-- Replace all sets of mutually-recursive declarations in a module with binding groups

4736--

48−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

49−createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps

37+createBindingGroupsModule

38+ :: (Functor m, Applicative m, MonadError MultipleErrors m)

39+ => [Module]

40+ -> m [Module]

41+createBindingGroupsModule =

42+ mapM $ \(Module ss coms name ds exps) ->

43+ Module ss coms name <$> createBindingGroups name ds <*> pure exps

5044

5145-- |

5246-- Collapse all binding groups in a module to individual declarations

5347--

5448collapseBindingGroupsModule :: [Module] -> [Module]

55−collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

56−

57−createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

49+collapseBindingGroupsModule =

50+ map $ \(Module ss coms name ds exps) ->

51+ Module ss coms name (collapseBindingGroups ds) exps

52+

53+createBindingGroups

54+ :: forall m

55+ . (Functor m, Applicative m, MonadError MultipleErrors m)

56+ => ModuleName

57+ -> [Declaration]

58+ -> m [Declaration]

5859createBindingGroups moduleName = mapM f <=< handleDecls

5960

6061 where

@@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls

7172 handleDecls ds = do

7273 let values = filter isValueDecl ds

7374 dataDecls = filter isDataDecl ds

74− allProperNames = map getProperName dataDecls

75− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

75+ allProperNames = map getTypeName dataDecls

76+ dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls

7677 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

7778 let allIdents = map getIdent values

7879 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

@@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls

9091-- Collapse all binding groups to individual declarations

9192--

9293collapseBindingGroups :: [Declaration] -> [Declaration]

93−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go

94+collapseBindingGroups =

95+ let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id

96+ in map f . concatMap go

9497 where

9598 go (DataBindingGroupDeclaration ds) = ds

96− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

97− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d

99+ go (BindingGroupDeclaration ds) =

100+ map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

101+ go (PositionedDeclaration pos com d) =

102+ map (PositionedDeclaration pos com) $ go d

98103 go other = [other]

99104

100105collapseBindingGroupsForValue :: Expr -> Expr

@@ -114,8 +119,10 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue

114119 (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

115120

116121 usedNamesE :: S.Set Ident -> Expr -> [Ident]

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

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

122+ usedNamesE scope (Var (Qualified Nothing name))

123+ | name `S.notMember` scope = [name]

124+ usedNamesE scope (Var (Qualified (Just moduleName') name))

125+ | moduleName == moduleName' && name `S.notMember` scope = [name]

119126 usedNamesE _ _ = []

120127

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

@@ -127,21 +134,24 @@ usedImmediateIdents moduleName =

127134

128135 usedNamesE :: Bool -> Expr -> (Bool, [Ident])

129136 usedNamesE True (Var (Qualified Nothing name)) = (True, [name])

130− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])

137+ usedNamesE True (Var (Qualified (Just moduleName') name))

138+ | moduleName == moduleName' = (True, [name])

131139 usedNamesE True (Abs _ _) = (False, [])

132140 usedNamesE scope _ = (scope, [])

133141

134−usedProperNames :: ModuleName -> Declaration -> [ProperName]

135−usedProperNames moduleName =

142+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]

143+usedTypeNames moduleName =

136144 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

137145 in nub . f

138146 where

139− usedNames :: Type -> [ProperName]

140− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->

141− case qual of

142− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name

147+ usedNames :: Type -> [ProperName 'TypeName]

148+ usedNames (ConstrainedType constraints _) =

149+ flip mapMaybe constraints $ \case

150+ (Qualified (Just moduleName') name, _)

151+ | moduleName == moduleName' -> Just (coerceProperName name)

143152 _ -> Nothing

144− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

153+ usedNames (TypeConstructor (Qualified (Just moduleName') name))

154+ | moduleName == moduleName' = [name]

145155 usedNames _ = []

146156

147157getIdent :: Declaration -> Ident

@@ -149,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident

149159getIdent (PositionedDeclaration _ _ d) = getIdent d

150160getIdent _ = internalError "Expected ValueDeclaration"

151161

152−getProperName :: Declaration -> ProperName

153−getProperName (DataDeclaration _ pn _ _) = pn

154−getProperName (TypeSynonymDeclaration pn _ _) = pn

155−getProperName (PositionedDeclaration _ _ d) = getProperName d

156−getProperName _ = internalError "Expected DataDeclaration"

162+getTypeName :: Declaration -> ProperName 'TypeName

163+getTypeName (DataDeclaration _ pn _ _) = pn

164+getTypeName (TypeSynonymDeclaration pn _ _) = pn

165+getTypeName (PositionedDeclaration _ _ d) = getTypeName d

166+getTypeName _ = internalError "Expected DataDeclaration"

157167

158168-- |

159169-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

160170--

161171--

162−toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

172+toBindingGroup

173+ :: forall m

174+ . (Functor m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> SCC Declaration

177+ -> m Declaration

163178toBindingGroup _ (AcyclicSCC d) = return d

164179toBindingGroup moduleName (CyclicSCC ds') =

165180 -- Once we have a mutually-recursive group of declarations, we need to sort

@@ -188,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') =

188203 cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

189204 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

190205

191−toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

206+toDataBindingGroup

207+ :: MonadError MultipleErrors m

208+ => SCC Declaration

209+ -> m Declaration

192210toDataBindingGroup (AcyclicSCC d) = return d

193211toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

194212 Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

@@ -197,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds')

197215 | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

198216 | otherwise = return $ DataBindingGroupDeclaration ds'

199217

200−isTypeSynonym :: Declaration -> Maybe ProperName

218+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)

201219isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

202220isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

203221isTypeSynonym _ = Nothing

src/Language/PureScript/Sugar/CaseDeclarations.hs+9−18

@@ -150,7 +150,7 @@ toTuple _ = internalError "Not a value declaration"

150150makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

151151makeCaseDeclaration ident alternatives = do

152152 let namedArgs = map findName . fst <$> alternatives

153− argNames = map join $ foldl1 resolveNames namedArgs

153+ argNames = foldl1 resolveNames namedArgs

154154 args <- if allUnique (catMaybes argNames)

155155 then mapM argName argNames

156156 else replicateM (length argNames) freshIdent'

@@ -160,14 +160,11 @@ makeCaseDeclaration ident alternatives = do

160160 return $ ValueDeclaration ident Public [] (Right value)

161161 where

162162 -- We will construct a table of potential names.

163− -- VarBinders will become Just (Just _) which is a potential name.

164− -- NullBinder will become Just Nothing, which indicates that we may

163+ -- VarBinders will become Just _ which is a potential name.

164+ -- Everything else becomes Nothing, which indicates that we

165165 -- have to generate a name.

166− -- Everything else becomes Nothing, which indicates that we definitely

167− -- have to generate a name.

168− findName :: Binder -> Maybe (Maybe Ident)

169− findName NullBinder = Just Nothing

170− findName (VarBinder name) = Just (Just name)

166+ findName :: Binder -> Maybe Ident

167+ findName (VarBinder name) = Just name

171168 findName (PositionedBinder _ _ binder) = findName binder

172169 findName _ = Nothing

173170

@@ -182,19 +179,13 @@ makeCaseDeclaration ident alternatives = do

182179

183180 -- Combine two lists of potential names from two case alternatives

184181 -- by zipping correspoding columns.

185− resolveNames :: [Maybe (Maybe Ident)] ->

186− [Maybe (Maybe Ident)] ->

187− [Maybe (Maybe Ident)]

182+ resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]

188183 resolveNames = zipWith resolveName

189184

190185 -- Resolve a pair of names. VarBinder beats NullBinder, and everything

191186 -- else results in Nothing.

192− resolveName :: Maybe (Maybe Ident) ->

193− Maybe (Maybe Ident) ->

194− Maybe (Maybe Ident)

195− resolveName (Just (Just a)) (Just (Just b))

196− | a == b = Just (Just a)

187+ resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident

188+ resolveName (Just a) (Just b)

189+ | a == b = Just a

197190 | otherwise = Nothing

198− resolveName (Just Nothing) a = a

199− resolveName a (Just Nothing) = a

200191 resolveName _ _ = Nothing

src/Language/PureScript/Sugar/Names.hs+89−29

@@ -1,8 +1,15 @@

11{-# LANGUAGE FlexibleContexts #-}

22{-# LANGUAGE RecordWildCards #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TupleSections #-}

5−module Language.PureScript.Sugar.Names (desugarImports) where

6+module Language.PureScript.Sugar.Names

7+ ( desugarImports

8+ , desugarImportsWithEnv

9+ , Env

10+ , Imports(..)

11+ , Exports(..)

12+ ) where

613

714import Prelude ()

815import Prelude.Compat

@@ -16,6 +23,7 @@ import Control.Monad.Writer (MonadWriter(..), censor)

1623import Control.Monad.State.Lazy

1724

1825import qualified Data.Map as M

26+import qualified Data.Set as S

1927

2028import Language.PureScript.Crash

2129import Language.PureScript.AST

@@ -34,11 +42,20 @@ import Language.PureScript.Linter.Imports

3442-- modules should be topologically sorted beforehand.

3543--

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

37−desugarImports externs modules = do

45+desugarImports externs modules =

46+ fmap snd (desugarImportsWithEnv externs modules)

47+

48+desugarImportsWithEnv

49+ :: forall m

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

51+ => [ExternsFile]

52+ -> [Module]

53+ -> m (Env, [Module])

54+desugarImportsWithEnv externs modules = do

3855 env <- silence $ foldM externsEnv primEnv externs

3956 modules' <- traverse updateExportRefs modules

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

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

58+ (env',) <$> traverse (renameInModule' env') modules''

4259 where

4360 silence :: m a -> m a

4461 silence = censor (const mempty)

@@ -55,17 +72,17 @@ desugarImports externs modules = do

5572 return $ M.insert efModuleName (ss, imps, exps) env

5673 where

5774

58− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

75+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

5976 exportedTypes = mapMaybe toExportedType efExports

6077 where

6178 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

6279 where

63− forTyCon :: ExternsDeclaration -> Maybe ProperName

80+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

6481 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

6582 forTyCon _ = Nothing

6683 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

6784 toExportedType _ = Nothing

68− exportedTypeClasses :: [(ProperName, ModuleName)]

85+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

6986 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

7087 where

7188 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

@@ -94,7 +111,7 @@ desugarImports externs modules = do

94111 warnAndRethrow (addHint (ErrorInModule mn)) $ do

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

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

97− findUnusedImports m env used

114+ lintImports m env used

98115 return m'

99116

100117-- |

@@ -119,14 +136,23 @@ elaborateExports exps (Module ss coms mn decls refs) =

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

120137-- qualified names are valid.

121138--

122−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module

139+renameInModule

140+ :: forall m

141+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

142+ => Env

143+ -> Imports

144+ -> Module

145+ -> m Module

123146renameInModule env imports (Module ss coms mn decls exps) =

124147 Module ss coms mn <$> parU decls go <*> pure exps

125148 where

126149

127150 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

128151

129− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

152+ updateDecl

153+ :: (Maybe SourceSpan, [Ident])

154+ -> Declaration

155+ -> m ((Maybe SourceSpan, [Ident]), Declaration)

130156 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

131157 return ((Just pos, bound), d)

132158 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

@@ -141,9 +167,14 @@ renameInModule env imports (Module ss coms mn decls exps) =

141167 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

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

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

170+ updateDecl (pos, bound) (FixityDeclaration fx name alias) =

171+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)

144172 updateDecl s d = return (s, d)

145173

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

174+ updateValue

175+ :: (Maybe SourceSpan, [Ident])

176+ -> Expr

177+ -> m ((Maybe SourceSpan, [Ident]), Expr)

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

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

149180 updateValue (pos, bound) (Abs (Left arg) val') =

@@ -164,7 +195,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

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

165196 updateValue s v = return (s, v)

166197

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

198+ updateBinder

199+ :: (Maybe SourceSpan, [Ident])

200+ -> Binder

201+ -> m ((Maybe SourceSpan, [Ident]), Binder)

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

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

170204 updateBinder s@(pos, _) (ConstructorBinder name b) =

@@ -176,7 +210,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

176210 updateBinder s v =

177211 return (s, v)

178212

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

213+ updateCase

214+ :: (Maybe SourceSpan, [Ident])

215+ -> CaseAlternative

216+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

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

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

182219

@@ -196,16 +233,25 @@ renameInModule env imports (Module ss coms mn decls exps) =

196233 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

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

198235

199− updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

236+ updateTypeName

237+ :: Qualified (ProperName 'TypeName)

238+ -> Maybe SourceSpan

239+ -> m (Qualified (ProperName 'TypeName))

240+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)

201241

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

242+ updateDataConstructorName

243+ :: Qualified (ProperName 'ConstructorName)

244+ -> Maybe SourceSpan

245+ -> m (Qualified (ProperName 'ConstructorName))

203246 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

204247

205− updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

248+ updateClassName

249+ :: Qualified (ProperName 'ClassName)

250+ -> Maybe SourceSpan

251+ -> m (Qualified (ProperName 'ClassName))

252+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)

207253

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

254+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

209255 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

210256

211257 -- Used when performing an update to qualify values and classes with their

@@ -215,12 +261,18 @@ renameInModule env imports (Module ss coms mn decls exps) =

215261

216262 -- Used when performing an update to qualify types with their module of

217263 -- original definition.

218− resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

264+ resolveType

265+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

266+ -> ProperName 'TypeName

267+ -> Maybe (Qualified (ProperName 'TypeName))

219268 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

220269

221270 -- Used when performing an update to qualify data constructors with their

222271 -- module of original definition.

223− resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

272+ resolveDctor

273+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

274+ -> ProperName 'ConstructorName

275+ -> Maybe (Qualified (ProperName 'ConstructorName))

224276 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

225277

226278 -- Update names so unqualified references become qualified, and locally

@@ -255,42 +307,50 @@ renameInModule env imports (Module ss coms mn decls exps) =

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

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

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

258− modExports <- getExports env mn''

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

310+ case M.lookup mn'' env of

311+ Nothing

312+ | mn'' `S.member` importedVirtualModules imports -> throwUnknown

313+ | otherwise -> throwError . errorMessage $ UnknownModule mn''

314+ Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

260315

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

262317 -- unimported symbol.

263− _ -> throwError . errorMessage $ unknown qname

318+ _ -> throwUnknown

264319

265320 where

266321 positioned err = case pos of

267322 Nothing -> err

268323 Just pos' -> rethrowWithPosition pos' err

324+ throwUnknown = throwError . errorMessage $ unknown qname

269325

270326-- |

271327-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

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

273329-- desugars into a `TypeClassRef`.

274330--

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

331+updateExportRefs

332+ :: forall m

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

334+ => Module

335+ -> m Module

276336updateExportRefs (Module ss coms mn decls exps) =

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

278338 where

279339

280340 updateRef :: DeclarationRef -> m DeclarationRef

281341 updateRef (ProperRef name)

282− | name `elem` classNames = do

283− tell . errorMessage $ DeprecatedClassExport name

284− return $ TypeClassRef name

342+ | ProperName name `elem` classNames = do

343+ tell . errorMessage . DeprecatedClassExport $ ProperName name

344+ return . TypeClassRef $ ProperName name

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

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

287347 -- be picked up elsewhere

288− | otherwise = return $ TypeRef name (Just [])

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

289349 updateRef (PositionedDeclarationRef pos com ref) =

290350 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

291351 updateRef other = return other

292352

293− classNames :: [ProperName]

353+ classNames :: [ProperName 'ClassName]

294354 classNames = mapMaybe go decls

295355 where

296356 go (PositionedDeclaration _ _ d) = go d

src/Language/PureScript/Sugar/Names/Env.hs+20−15

@@ -22,6 +22,7 @@ import Data.Function (on)

2222import Data.List (groupBy, sortBy, nub)

2323import Data.Maybe (fromJust)

2424import qualified Data.Map as M

25+import qualified Data.Set as S

2526

2627import Control.Monad

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

@@ -40,30 +41,35 @@ data Imports = Imports

4041 -- |

4142 -- Local names for types within a module mapped to to their qualified names

4243 --

43− importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

44+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]

4445 -- |

4546 -- Local names for data constructors within a module mapped to to their qualified names

4647 --

47− , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

48+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]

4849 -- |

4950 -- Local names for classes within a module mapped to to their qualified names

5051 --

51− , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

52+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]

5253 -- |

5354 -- Local names for values within a module mapped to to their qualified names

5455 --

5556 , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]

5657 -- |

57− -- The list of modules that have been imported into the current scope.

58+ -- The modules that have been imported into the current scope.

5859 --

59− , importedModules :: [ModuleName]

60+ , importedModules :: S.Set ModuleName

61+ -- |

62+ -- The names of "virtual" modules that come into existence when "import as"

63+ -- is used.

64+ --

65+ , importedVirtualModules :: S.Set ModuleName

6066 } deriving (Show, Read)

6167

6268-- |

6369-- An empty 'Imports' value.

6470--

6571nullImports :: Imports

66−nullImports = Imports M.empty M.empty M.empty M.empty []

72+nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty

6773

6874-- |

6975-- The exported declarations from a module.

@@ -74,12 +80,12 @@ data Exports = Exports

7480 -- The types exported from each module along with the module they originally

7581 -- came from.

7682 --

77− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

83+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

7884 -- |

7985 -- The classes exported from each module along with the module they originally

8086 -- came from.

8187 --

82− , exportedTypeClasses :: [(ProperName, ModuleName)]

88+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

8389 -- |

8490 -- The values exported from each module along with the module they originally

8591 -- came from.

@@ -137,29 +143,28 @@ primEnv = M.singleton

137143-- Safely adds a type and its data constructors to some exports, returning an

138144-- error if a conflict occurs.

139145--

140−exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

146+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports

141147exportType exps name dctors mn = do

142148 let exTypes' = exportedTypes exps

143149 let exTypes = filter ((/= mn) . snd) exTypes'

144150 let exDctors = (snd . fst) `concatMap` exTypes

145151 let exClasses = exportedTypeClasses exps

146−

147152 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

148− when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

153+ when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

149154 forM_ dctors $ \dctor -> do

150155 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

151− when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

156+ when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

152157 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

153158

154159-- |

155160-- Safely adds a class to some exports, returning an error if a conflict occurs.

156161--

157−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports

162+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

158163exportTypeClass exps name mn = do

159164 let exTypes = exportedTypes exps

160165 let exDctors = (snd . fst) `concatMap` exTypes

161− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

162− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

166+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

167+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

163168 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

164169 return $ exps { exportedTypeClasses = classes }

165170

src/Language/PureScript/Sugar/Names/Exports.hs+31−8

@@ -75,7 +75,7 @@ resolveExports env mn imps exps refs =

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

7676 _ -> return ()

7777

78− warnDupeDctors :: [ProperName] -> m ()

78+ warnDupeDctors :: [ProperName 'ConstructorName] -> m ()

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

8080

8181 warnDupe :: String -> m ()

@@ -151,10 +151,15 @@ resolveExports env mn imps exps refs =

151151

152152 -- Constructs a list of types with their data constructors and the original

153153 -- module they were defined in from a list of type and data constructor names.

154− resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]

154+ resolveTypeExports

155+ :: [Qualified (ProperName 'TypeName)]

156+ -> [Qualified (ProperName 'ConstructorName)]

157+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

155158 resolveTypeExports tctors dctors = map go tctors

156159 where

157− go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

160+ go

161+ :: Qualified (ProperName 'TypeName)

162+ -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)

158163 go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159164 exps' <- envModuleExports <$> mn'' `M.lookup` env

160165 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

@@ -165,7 +170,7 @@ resolveExports env mn imps exps refs =

165170

166171 -- Looks up an imported class and re-qualifies it with the original module it

167172 -- came from.

168− resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

173+ resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)

169174 resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

170175 resolve exportedTypeClasses className

171176

@@ -192,7 +197,13 @@ resolveExports env mn imps exps refs =

192197-- Filters the full list of exportable values, types, and classes for a module

193198-- based on a list of export declaration references.

194199--

195−filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports

200+filterModule

201+ :: forall m

202+ . (Applicative m, MonadError MultipleErrors m)

203+ => ModuleName

204+ -> Exports

205+ -> [DeclarationRef]

206+ -> m Exports

196207filterModule mn exps refs = do

197208 types <- foldM (filterTypes $ exportedTypes exps) [] refs

198209 values <- foldM (filterValues $ exportedValues exps) [] refs

@@ -206,7 +217,11 @@ filterModule mn exps refs = do

206217 -- explicit export. When the ref refers to a type in the list of exportable

207218 -- values, the type and specified data constructors are included in the

208219 -- result.

209− filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]

220+ filterTypes

221+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

222+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

223+ -> DeclarationRef

224+ -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

210225 filterTypes exps' result (PositionedDeclarationRef pos _ r) =

211226 rethrowWithPosition pos $ filterTypes exps' result r

212227 filterTypes exps' result (TypeRef name expDcons) =

@@ -221,7 +236,11 @@ filterModule mn exps refs = do

221236 -- Ensures a data constructor is exportable for a given type. Takes a type

222237 -- name, a list of exportable data constructors for the type, and the name of

223238 -- the data constructor to check.

224− checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()

239+ checkDcon

240+ :: ProperName 'TypeName

241+ -> [ProperName 'ConstructorName]

242+ -> ProperName 'ConstructorName

243+ -> m ()

225244 checkDcon tcon exps' name =

226245 unless (name `elem` exps') $

227246 throwError . errorMessage $ UnknownExportDataConstructor tcon name

@@ -230,7 +249,11 @@ filterModule mn exps refs = do

230249 -- filtered exports, and a `DeclarationRef` for an explicit export. When the

231250 -- ref refers to a class in the list of exportable classes, the class is

232251 -- included in the result.

233− filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]

252+ filterClasses

253+ :: [(ProperName 'ClassName, ModuleName)]

254+ -> [(ProperName 'ClassName, ModuleName)]

255+ -> DeclarationRef

256+ -> m [(ProperName 'ClassName, ModuleName)]

234257 filterClasses exps' result (PositionedDeclarationRef pos _ r) =

235258 rethrowWithPosition pos $ filterClasses exps' result r

236259 filterClasses exps' result (TypeClassRef name) =

src/Language/PureScript/Sugar/Names/Imports.hs+25−12

@@ -23,6 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))

2323import Control.Monad.Writer (MonadWriter(..))

2424

2525import qualified Data.Map as M

26+import qualified Data.Set as S

2627

2728import Language.PureScript.Crash

2829import Language.PureScript.AST

@@ -123,7 +124,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

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

124125 _ -> return ()

125126

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

127+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()

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

128129

129130 warnDupe :: Maybe SourceSpan -> String -> m ()

@@ -134,7 +135,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

134135

135136 updateImportRef :: Declaration -> m Declaration

136137 updateImportRef (PositionedDeclaration pos com d) =

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

138+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138139 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139140 modExports <- getExports env mn

140141 typ' <- case typ of

@@ -146,11 +147,11 @@ resolveImports env (Module ss coms currentModule decls exps) =

146147

147148 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148149 updateProperRef importModule modExports (ProperRef name) =

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

150+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)

150151 then do

151− tell . errorMessage $ DeprecatedClassImport importModule name

152− return $ TypeClassRef name

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

152+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)

153+ return . TypeClassRef $ ProperName name

154+ else return $ TypeRef (ProperName name) (Just [])

154155 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155156 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156157 updateProperRef _ _ other = return other

@@ -168,7 +169,10 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

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

169170 go ie' (pos, typ, impQual) = do

170171 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

171− let ie'' = ie' { importedModules = mn : importedModules ie' }

172+ let virtualModules = importedVirtualModules ie'

173+ ie'' = ie' { importedModules = S.insert mn (importedModules ie')

174+ , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

175+ }

172176 positioned $ resolveImport mn modExports ie'' impQual typ

173177 where

174178 positioned err = case pos of

@@ -222,13 +226,22 @@ resolveImport importModule exps imps impQual = resolveByType

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

223227

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

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

229+ checkImportExists

230+ :: Eq a

231+ => (ModuleName -> a -> SimpleErrorMessage)

232+ -> [a]

233+ -> a

234+ -> m ()

226235 checkImportExists unknown exports item =

227236 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

228237

229238 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

230239 -- from

231− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

240+ checkDctorExists

241+ :: ProperName 'TypeName

242+ -> [ProperName 'ConstructorName]

243+ -> ProperName 'ConstructorName

244+ -> m ()

232245 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

233246

234247 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

@@ -264,9 +277,9 @@ resolveImport importModule exps imps impQual = resolveByType

264277 return $ imp { importedValues = values' }

265278 importExplicit imp (TypeRef name dctors) = do

266279 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

267− let exportedDctors :: [(ProperName, ModuleName)]

280+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

268281 exportedDctors = allExportedDataConstructors name

269− dctorNames :: [ProperName]

282+ dctorNames :: [ProperName 'ConstructorName]

270283 dctorNames = fst `map` exportedDctors

271284 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

272285 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

@@ -278,7 +291,7 @@ resolveImport importModule exps imps impQual = resolveByType

278291 importExplicit _ _ = internalError "Invalid argument to importExplicit"

279292

280293 -- Find all exported data constructors for a given type

281− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

294+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

282295 allExportedDataConstructors name =

283296 case find ((== name) . fst . fst) (exportedTypes exps) of

284297 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/Operators.hs+9−9

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

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE TupleSections #-}

67-- |

78-- This module implements the desugaring pass which reapplies binary operators based

@@ -55,9 +56,8 @@ rebracket externs ms = do

5556

5657 where

5758

58− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)

59− makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)

60− makeLookupEntry _ = Nothing

59+ makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)

60+ makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

6161

6262 renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module

6363 renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

@@ -87,16 +87,16 @@ removeParens =

8787 go (Parens val) = val

8888 go val = val

8989

90−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

90+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

9191externsFixities ExternsFile{..} =

92− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

93− | ExternsFixity assoc prec op alias <- efFixities

94− ]

92+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

93+ | ExternsFixity assoc prec op alias <- efFixities

94+ ]

9595

96−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

96+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

9797collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

9898 where

99− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

99+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

100100 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

101101 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

102102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

src/Language/PureScript/Sugar/TypeClasses.hs+63−38

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

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

2−--

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

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

115-- |

126-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

137-- and dictionary expressions for type class instances.

148--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE RecordWildCards #-}

19−

209module Language.PureScript.Sugar.TypeClasses

2110 ( desugarTypeClasses

2211 , typeClassMemberName

@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)

4736

4837import qualified Data.Map as M

4938

50−type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])

39+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])

5140

5241type Desugar = StateT MemberMap

5342

@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap

5544-- Add type synonym declarations for type class dictionary types, and value declarations for type class

5645-- instance dictionary expressions.

5746--

58−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

47+desugarTypeClasses

48+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

49+ => [ExternsFile]

50+ -> [Module]

51+ -> m [Module]

5952desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

6053 where

6154 initialState :: MemberMap

6255 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

6356

64− fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

57+ fromExternsDecl

58+ :: ModuleName

59+ -> ExternsDeclaration

60+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

6561 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

6662 fromExternsDecl _ _ = Nothing

6763

68−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

64+desugarModule

65+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

66+ => Module

67+ -> Desugar m Module

6968desugarModule (Module ss coms name decls (Just exps)) = do

7069 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

7170 return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

@@ -171,7 +170,12 @@ desugarModule _ = internalError "Exports should have been elaborated in name des

171170-- return new Sub(fooString, "");

172171-- };

173172-}

174−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

173+desugarDecl

174+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> [DeclarationRef]

177+ -> Declaration

178+ -> Desugar m (Maybe DeclarationRef, [Declaration])

175179desugarDecl mn exps = go

176180 where

177181 go d@(TypeClassDeclaration name args implies members) = do

@@ -187,48 +191,60 @@ desugarDecl mn exps = go

187191 return (dr, map (PositionedDeclaration pos com) ds)

188192 go other = return (Nothing, [other])

189193

190− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

194+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef

191195 expRef name className tys

192196 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

193197 | otherwise = Nothing

194198

195− isExportedClass :: Qualified ProperName -> Bool

199+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool

196200 isExportedClass = isExported (elem . TypeClassRef)

197201

198− isExportedType :: Qualified ProperName -> Bool

202+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool

199203 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

200204

201− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

205+ isExported

206+ :: (ProperName a -> [DeclarationRef] -> Bool)

207+ -> Qualified (ProperName a)

208+ -> Bool

202209 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203210 isExported _ _ = internalError "Names should have been qualified in name desugaring"

204211

205− matchesTypeRef :: ProperName -> DeclarationRef -> Bool

212+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool

206213 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207214 matchesTypeRef _ _ = False

208215

209− getConstructors :: Type -> [Qualified ProperName]

216+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]

210217 getConstructors = everythingOnTypes (++) getConstructor

211−

212− getConstructor :: Type -> [Qualified ProperName]

213− getConstructor (TypeConstructor tcname) = [tcname]

214− getConstructor _ = []

218+ where

219+ getConstructor (TypeConstructor tcname) = [tcname]

220+ getConstructor _ = []

215221

216222memberToNameAndType :: Declaration -> (Ident, Type)

217223memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218224memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219225memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220226

221−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

227+typeClassDictionaryDeclaration

228+ :: ProperName 'ClassName

229+ -> [(String, Maybe Kind)]

230+ -> [Constraint]

231+ -> [Declaration]

232+ -> Declaration

222233typeClassDictionaryDeclaration name args implies members =

223234 let superclassTypes = superClassDictionaryNames implies `zip`

224− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)

235+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

225236 | (superclass, tyArgs) <- implies

226237 ]

227238 members' = map (first runIdent . memberToNameAndType) members

228239 mtys = members' ++ superclassTypes

229− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

230−

231−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

240+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))

241+

242+typeClassMemberToDictionaryAccessor

243+ :: ModuleName

244+ -> ProperName 'ClassName

245+ -> [(String, Maybe Kind)]

246+ -> Declaration

247+ -> Declaration

232248typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

233249 let className = Qualified (Just mn) name

234250 in ValueDeclaration ident Private [] $ Right $

@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration

241257unit :: Type

242258unit = TypeApp tyObject REmpty

243259

244−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

260+typeInstanceDictionaryDeclaration

261+ :: forall m

262+ . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

263+ => Ident

264+ -> ModuleName

265+ -> [Constraint]

266+ -> Qualified (ProperName 'ClassName)

267+ -> [Type]

268+ -> [Declaration]

269+ -> Desugar m Declaration

245270typeInstanceDictionaryDeclaration name mn deps className tys decls =

246271 rethrow (addHint (ErrorInInstance className tys)) $ do

247272 m <- get

@@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

273298 ]

274299

275300 let props = ObjectLiteral (members ++ superclasses)

276− dictTy = foldl TypeApp (TypeConstructor className) tys

301+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

277302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

278303 dict = TypeClassDictionaryConstructorApp className props

279304 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

287312 declName (TypeDeclaration ident _) = Just ident

288313 declName _ = Nothing

289314

290− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

315+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr

291316 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292317 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293318 return val

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+32−14

@@ -8,9 +8,7 @@

88-- |

99-- This module implements the generic deriving elaboration that takes place during desugaring.

1010--

11−module Language.PureScript.Sugar.TypeClasses.Deriving (

12− deriveInstances

13−) where

11+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

1412

1513import Prelude ()

1614import Prelude.Compat

@@ -32,12 +30,20 @@ import Language.PureScript.Types

3230import qualified Language.PureScript.Constants as C

3331

3432-- | Elaborates deriving instance declarations by code generation.

35−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module

33+deriveInstances

34+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)

35+ => Module

36+ -> m Module

3637deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

3738

3839-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

3940-- elaborates that into an instance declaration via code generation.

40−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

41+deriveInstance

42+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

43+ => ModuleName

44+ -> [Declaration]

45+ -> Declaration

46+ -> m Declaration

4147deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

4248 | className == Qualified (Just dataGeneric) (ProperName C.generic)

4349 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

@@ -48,7 +54,7 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

4854deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

4955deriveInstance _ _ e = return e

5056

51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

57+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

5258unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

5359unwrapTypeConstructor (TypeApp ty arg) = do

5460 (tyCon, args) <- unwrapTypeConstructor ty

@@ -64,7 +70,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

6470typesProxy :: ModuleName

6571typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

6672

67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

73+deriveGeneric

74+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

75+ => ModuleName

76+ -> [Declaration]

77+ -> ProperName 'TypeName

78+ -> [Type]

79+ -> m [Declaration]

6880deriveGeneric mn ds tyConNm args = do

6981 tyCon <- findTypeDecl tyConNm ds

7082 toSpine <- mkSpineFunction mn tyCon

@@ -75,7 +87,11 @@ deriveGeneric mn ds tyConNm args = do

7587 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

7688 ]

7789

78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

90+findTypeDecl

91+ :: (Functor m, MonadError MultipleErrors m)

92+ => ProperName 'TypeName

93+ -> [Declaration]

94+ -> m Declaration

7995findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

8096 where

8197 isTypeDecl :: Declaration -> Bool

@@ -92,7 +108,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

92108 recordConstructor :: Expr -> Expr

93109 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

94110

95− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

111+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

96112 mkCtorClause (ctorName, tys) = do

97113 idents <- replicateM (length tys) freshIdent'

98114 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

@@ -125,10 +141,12 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull

125141 proxy :: Type -> Type

126142 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

127143

128− mkProdClause :: (ProperName, [Type]) -> Expr

129− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

130− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

131− ]

144+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

145+ mkProdClause (ctorName, tys) =

146+ ObjectLiteral

147+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

148+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

149+ ]

132150

133151 mkProductSignature :: Type -> Expr

134152 mkProductSignature r | Just rec <- objectType r =

@@ -158,7 +176,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

158176 recordBinder :: [Binder] -> Binder

159177 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

160178

161− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

179+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

162180 mkAlternative (ctorName, tys) = do

163181 idents <- replicateM (length tys) freshIdent'

164182 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

src/Language/PureScript/TypeChecker.hs+82−79

@@ -39,15 +39,15 @@ import Language.PureScript.TypeClassDictionaries

3939import Language.PureScript.Environment

4040import Language.PureScript.Errors

4141

42−addDataType ::

43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

44− ModuleName ->

45− DataDeclType ->

46− ProperName ->

47− [(String, Maybe Kind)] ->

48− [(ProperName, [Type])] ->

49− Kind ->

50− m ()

42+addDataType

43+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

44+ => ModuleName

45+ -> DataDeclType

46+ -> ProperName 'TypeName

47+ -> [(String, Maybe Kind)]

48+ -> [(ProperName 'ConstructorName, [Type])]

49+ -> Kind

50+ -> m ()

5151addDataType moduleName dtype name args dctors ctorKind = do

5252 env <- getEnv

5353 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

@@ -55,15 +55,15 @@ addDataType moduleName dtype name args dctors ctorKind = do

5555 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $

5656 addDataConstructor moduleName dtype name (map fst args) dctor tys

5757

58−addDataConstructor ::

59− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

60− ModuleName ->

61− DataDeclType ->

62− ProperName ->

63− [String] ->

64− ProperName ->

65− [Type] ->

66− m ()

58+addDataConstructor

59+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60+ => ModuleName

61+ -> DataDeclType

62+ -> ProperName 'TypeName

63+ -> [String]

64+ -> ProperName 'ConstructorName

65+ -> [Type]

66+ -> m ()

6767addDataConstructor moduleName dtype name args dctor tys = do

6868 env <- getEnv

6969 traverse_ checkTypeSynonyms tys

@@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do

7373 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]

7474 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

7575

76−addTypeSynonym ::

77− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

78− ModuleName ->

79− ProperName ->

80− [(String, Maybe Kind)] ->

81− Type ->

82− Kind ->

83− m ()

76+addTypeSynonym

77+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

78+ => ModuleName

79+ -> ProperName 'TypeName

80+ -> [(String, Maybe Kind)]

81+ -> Type

82+ -> Kind

83+ -> m ()

8484addTypeSynonym moduleName name args ty kind = do

8585 env <- getEnv

8686 checkTypeSynonyms ty

8787 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

8888 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

8989

90−valueIsNotDefined ::

91− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

92− ModuleName ->

93− Ident ->

94− m ()

90+valueIsNotDefined

91+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

92+ => ModuleName

93+ -> Ident

94+ -> m ()

9595valueIsNotDefined moduleName name = do

9696 env <- getEnv

9797 case M.lookup (moduleName, name) (names env) of

9898 Just _ -> throwError . errorMessage $ RedefinedIdent name

9999 Nothing -> return ()

100100

101−addValue ::

102− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

103− ModuleName ->

104− Ident ->

105− Type ->

106− NameKind ->

107− m ()

101+addValue

102+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

103+ => ModuleName

104+ -> Ident

105+ -> Type

106+ -> NameKind

107+ -> m ()

108108addValue moduleName name ty nameKind = do

109109 env <- getEnv

110110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

111111

112−addTypeClass ::

113− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

114− ModuleName ->

115− ProperName ->

116− [(String, Maybe Kind)] ->

117− [Constraint] ->

118− [Declaration] ->

119− m ()

112+addTypeClass

113+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

114+ => ModuleName

115+ -> ProperName 'ClassName

116+ -> [(String, Maybe Kind)]

117+ -> [Constraint]

118+ -> [Declaration]

119+ -> m ()

120120addTypeClass moduleName pn args implies ds =

121121 let members = map toPair ds in

122122 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

@@ -125,30 +125,30 @@ addTypeClass moduleName pn args implies ds =

125125 toPair (PositionedDeclaration _ _ d) = toPair d

126126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

127127

128−addTypeClassDictionaries ::

129− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

130− Maybe ModuleName ->

131− M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->

132− m ()

128+addTypeClassDictionaries

129+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

130+ => Maybe ModuleName

131+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

132+ -> m ()

133133addTypeClassDictionaries mn entries =

134134 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

135135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

136136

137−checkDuplicateTypeArguments ::

138− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

139− [String] ->

140− m ()

137+checkDuplicateTypeArguments

138+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

139+ => [String]

140+ -> m ()

141141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

142142 throwError . errorMessage $ DuplicateTypeArgument dup

143143 where

144144 firstDup :: Maybe String

145145 firstDup = listToMaybe $ args \\ nub args

146146

147−checkTypeClassInstance ::

148− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

149− ModuleName ->

150− Type ->

151− m ()

147+checkTypeClassInstance

148+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149+ => ModuleName

150+ -> Type

151+ -> m ()

152152checkTypeClassInstance _ (TypeVar _) = return ()

153153checkTypeClassInstance _ (TypeConstructor ctor) = do

154154 env <- getEnv

@@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

160160-- |

161161-- Check that type synonyms are fully-applied in a type

162162--

163−checkTypeSynonyms ::

164− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

165− Type ->

166− m ()

163+checkTypeSynonyms

164+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165+ => Type

166+ -> m ()

167167checkTypeSynonyms = void . replaceAllTypeSynonyms

168168

169169-- |

@@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

179179--

180180-- * Process module imports

181181--

182−typeCheckAll :: forall m.

183− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

184− ModuleName ->

185− [DeclarationRef] ->

186− [Declaration] ->

187− m [Declaration]

182+typeCheckAll

183+ :: forall m

184+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185+ => ModuleName

186+ -> [DeclarationRef]

187+ -> [Declaration]

188+ -> m [Declaration]

188189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189190 where

190191 go :: Declaration -> m Declaration

@@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

197198 addDataType moduleName dtype name args' dctors ctorKind

198199 return $ DataDeclaration dtype name args dctors

199200 where

200− checkNewtype :: [(ProperName, [Type])] -> m ()

201+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()

201202 checkNewtype [(_, [_])] = return ()

202203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

@@ -281,7 +282,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

281282

282283 checkFixities :: Declaration -> m ()

283284 checkFixities (FixityDeclaration _ name (Just alias)) = do

284− ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)

285+ ty <- lookupVariable moduleName alias

285286 addValue moduleName (Op name) ty Public

286287 checkFixities (FixityDeclaration _ name _) = do

287288 env <- getEnv

@@ -308,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

308309 | otherwise = firstDuplicate xs

309310 firstDuplicate _ = Nothing

310311

311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()

312+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

312313 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313314 | moduleName == mn' || any checkType tys' = return ()

314315 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

@@ -335,10 +336,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

335336-- Type check an entire module and ensure all types and classes defined within the module that are

336337-- required by exported members are also exported.

337338--

338−typeCheckModule :: forall m.

339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

340− Module ->

341− m Module

339+typeCheckModule

340+ :: forall m

341+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

342+ => Module

343+ -> m Module

342344typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

343345typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

344346 modify (\s -> s { checkCurrentModule = Just mn })

@@ -403,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

403405 where

404406 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

405407 go _ = []

406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

408+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

407409 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

408410 extractCurrentModuleClass _ = Nothing

409411

@@ -433,6 +435,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

433435 where

434436 getAlias :: Declaration -> Maybe Ident

435437 getAlias (PositionedDeclaration _ _ d) = getAlias d

436− getAlias (FixityDeclaration _ name' alias) | name == name' = alias

438+ getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))

439+ | mn == mn' && name == name' = Just alias

437440 getAlias _ = Nothing

438441 checkNonAliasesAreExported _ = return ()

src/Language/PureScript/TypeChecker/Entailment.hs+14−27

@@ -1,24 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.TypeChecker.Entailment

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Type class entailment

13−--

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

15−

161{-# LANGUAGE ScopedTypeVariables #-}

172{-# LANGUAGE FlexibleContexts #-}

183

19−module Language.PureScript.TypeChecker.Entailment (

20− entails

21−) where

4+-- |

5+-- Type class entailment

6+--

7+module Language.PureScript.TypeChecker.Entailment (entails) where

228

239import Prelude ()

2410import Prelude.Compat

@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C

4632-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

4733-- return a type class dictionary reference.

4834--

49−entails :: forall m.

50− (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

51− ModuleName ->

52− M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->

53− Constraint ->

54− m Expr

35+entails

36+ :: forall m

37+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

38+ => ModuleName

39+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

40+ -> Constraint

41+ -> m Expr

5542entails moduleName context = solve

5643 where

57− forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

44+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

5845 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

5946 forClassName _ _ = internalError "forClassName: expected qualified class name"

6047

@@ -64,7 +51,7 @@ entails moduleName context = solve

6451 ctorModules (TypeApp ty _) = ctorModules ty

6552 ctorModules _ = Nothing

6653

67− findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

54+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

6855 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

6956

7057 solve :: Constraint -> m Expr

@@ -72,7 +59,7 @@ entails moduleName context = solve

7259 dict <- go 0 className tys

7360 return $ dictionaryValueToValue dict

7461 where

75− go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue

62+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue

7663 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

7764 go work className' tys' = do

7865 let instances = do

src/Language/PureScript/TypeChecker/Kinds.hs+64−51

@@ -1,18 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.TypeChecker.Kinds

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the kind checker

13−--

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

15−

161{-# LANGUAGE MultiParamTypeClasses #-}

172{-# LANGUAGE FlexibleInstances #-}

183{-# LANGUAGE FlexibleContexts #-}

@@ -20,12 +5,15 @@

205{-# LANGUAGE ScopedTypeVariables #-}

216{-# LANGUAGE RankNTypes #-}

227

23−module Language.PureScript.TypeChecker.Kinds (

24− kindOf,

25− kindOfWithScopedVars,

26− kindsOf,

27− kindsOfAll

28−) where

8+-- |

9+-- This module implements the kind checker

10+--

11+module Language.PureScript.TypeChecker.Kinds

12+ ( kindOf

13+ , kindOfWithScopedVars

14+ , kindsOf

15+ , kindsOfAll

16+ ) where

2917

3018import Prelude ()

3119import Prelude.Compat

@@ -54,7 +42,11 @@ freshKind = do

5442 return $ KUnknown k

5543

5644-- | Update the substitution to solve a kind constraint

57−solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()

45+solveKind

46+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

47+ => Int

48+ -> Kind

49+ -> m ()

5850solveKind u k = do

5951 occursCheck u k

6052 modify $ \cs -> cs { checkSubstitution =

@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go

7567 go other = other

7668

7769-- | Make sure that an unknown does not occur in a kind

78−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()

70+occursCheck

71+ :: (Functor m, Applicative m, MonadError MultipleErrors m)

72+ => Int

73+ -> Kind

74+ -> m ()

7975occursCheck _ KUnknown{} = return ()

8076occursCheck u k = void $ everywhereOnKindsM go k

8177 where

@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k

8379 go other = return other

8480

8581-- | Unify two kinds

86−unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()

82+unifyKinds

83+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

84+ => Kind

85+ -> Kind

86+ -> m ()

8787unifyKinds k1 k2 = do

8888 sub <- gets checkSubstitution

8989 go (substituteKind sub k1) (substituteKind sub k2)

@@ -100,10 +100,10 @@ unifyKinds k1 k2 = do

100100 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'

101101

102102-- | Infer the kind of a single type

103−kindOf ::

104− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

105− Type ->

106− m Kind

103+kindOf

104+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

105+ => Type

106+ -> m Kind

107107kindOf ty = fst <$> kindOfWithScopedVars ty

108108

109109-- | Infer the kind of a single type, returning the kinds of any scoped type variables

@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =

120120 )

121121

122122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

123−kindsOf ::

124− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

125− Bool ->

126− ModuleName ->

127− ProperName ->

128− [(String, Maybe Kind)] ->

129− [Type] ->

130− m Kind

123+kindsOf

124+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

125+ => Bool

126+ -> ModuleName

127+ -> ProperName 'TypeName

128+ -> [(String, Maybe Kind)]

129+ -> [Type]

130+ -> m Kind

131131kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

132132 tyCon <- freshKind

133133 kargs <- replicateM (length args) freshKind

@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

138138 where

139139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k

140140

141−freshKindVar ::

142− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>

143− (String, Maybe Kind) ->

144− Kind ->

145− m (ProperName, Kind)

141+freshKindVar

142+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

143+ => (String, Maybe Kind)

144+ -> Kind

145+ -> m (ProperName 'TypeName, Kind)

146146freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

147147freshKindVar (arg, Just kind') kind = do

148148 unifyKinds kind kind'

149149 return (ProperName arg, kind')

150150

151151-- | Simultaneously infer the kinds of several mutually recursive type constructors

152−kindsOfAll ::

153− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

154− ModuleName ->

155− [(ProperName, [(String, Maybe Kind)], Type)] ->

156− [(ProperName, [(String, Maybe Kind)], [Type])] ->

157− m ([Kind], [Kind])

152+kindsOfAll

153+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

154+ => ModuleName

155+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

156+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

157+ -> m ([Kind], [Kind])

158158kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

159159 synVars <- replicateM (length syns) freshKind

160160 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

177177 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)

178178

179179-- | Solve the set of kind constraints associated with the data constructors for a type constructor

180−solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind

180+solveTypes

181+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

182+ => Bool

183+ -> [Type]

184+ -> [Kind]

185+ -> Kind

186+ -> m Kind

181187solveTypes isData ts kargs tyCon = do

182188 ks <- traverse (fmap fst . infer) ts

183189 when isData $ do

@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

195201starIfUnknown k = k

196202

197203-- | Infer a kind for a type

198−infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

204+infer

205+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

206+ => Type

207+ -> m (Kind, [(String, Kind)])

199208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

200209

201−infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

210+infer'

211+ :: forall m

212+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

213+ => Type

214+ -> m (Kind, [(String, Kind)])

202215infer' (ForAll ident ty _) = do

203216 k1 <- freshKind

204217 Just moduleName <- checkCurrentModule <$> get

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

250263 return $ Row k1

251264 go (ConstrainedType deps ty) = do

252265 forM_ deps $ \(className, tys) -> do

253− k <- go $ foldl TypeApp (TypeConstructor className) tys

266+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

254267 unifyKinds k Star

255268 k <- go ty

256269 unifyKinds k Star

src/Language/PureScript/TypeChecker/Monad.hs+63−32

@@ -1,18 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.TypeChecker.Monad

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Monads for type checking and type inference and associated data types

13−--

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

15−

161{-# LANGUAGE GeneralizedNewtypeDeriving #-}

172{-# LANGUAGE FlexibleInstances #-}

183{-# LANGUAGE RankNTypes #-}

@@ -20,6 +5,9 @@

205{-# LANGUAGE FlexibleContexts #-}

216{-# LANGUAGE GADTs #-}

227

8+-- |

9+-- Monads for type checking and type inference and associated data types

10+--

2311module Language.PureScript.TypeChecker.Monad where

2412

2513import Prelude ()

@@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

6957type Unknown = Int

7058

7159-- | Temporarily bind a collection of names to values

72−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a

60+bindNames

61+ :: MonadState CheckState m

62+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

63+ -> m a

64+ -> m a

7365bindNames newNames action = do

7466 orig <- get

7567 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -78,7 +70,11 @@ bindNames newNames action = do

7870 return a

7971

8072-- | Temporarily bind a collection of names to types

81−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a

73+bindTypes

74+ :: MonadState CheckState m

75+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

76+ -> m a

77+ -> m a

8278bindTypes newNames action = do

8379 orig <- get

8480 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -87,7 +83,12 @@ bindTypes newNames action = do

8783 return a

8884

8985-- | Temporarily bind a collection of names to types

90−withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a

86+withScopedTypeVars

87+ :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)

88+ => ModuleName

89+ -> [(String, Kind)]

90+ -> m a

91+ -> m a

9192withScopedTypeVars mn ks ma = do

9293 orig <- get

9394 forM_ ks $ \(name, _) ->

@@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do

9697 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

9798

9899-- | Temporarily make a collection of type class dictionaries available

99−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

100+withTypeClassDictionaries

101+ :: MonadState CheckState m

102+ => [TypeClassDictionaryInScope]

103+ -> m a

104+ -> m a

100105withTypeClassDictionaries entries action = do

101106 orig <- get

102107 let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

@@ -106,25 +111,35 @@ withTypeClassDictionaries entries action = do

106111 return a

107112

108113-- | Get the currently available map of type class dictionaries

109−getTypeClassDictionaries ::

110− (Functor m, MonadState CheckState m) =>

111− m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

114+getTypeClassDictionaries

115+ :: (Functor m, MonadState CheckState m)

116+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

112117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

113118

114119-- | Lookup type class dictionaries in a module.

115−lookupTypeClassDictionaries ::

116− (Functor m, MonadState CheckState m) =>

117− Maybe ModuleName ->

118− m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

120+lookupTypeClassDictionaries

121+ :: (Functor m, MonadState CheckState m)

122+ => Maybe ModuleName

123+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

119124lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

120125

121126-- | Temporarily bind a collection of names to local variables

122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

127+bindLocalVariables

128+ :: (Functor m, MonadState CheckState m)

129+ => ModuleName

130+ -> [(Ident, Type, NameVisibility)]

131+ -> m a

132+ -> m a

123133bindLocalVariables moduleName bindings =

124134 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

125135

126136-- | Temporarily bind a collection of names to local type variables

127−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

137+bindLocalTypeVariables

138+ :: (Functor m, MonadState CheckState m)

139+ => ModuleName

140+ -> [(ProperName 'TypeName, Kind)]

141+ -> m a

142+ -> m a

128143bindLocalTypeVariables moduleName bindings =

129144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

130145

@@ -145,7 +160,11 @@ preservingNames action = do

145160 return a

146161

147162-- | Lookup the type of a value by name in the @Environment@

148−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

163+lookupVariable

164+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

165+ => ModuleName

166+ -> Qualified Ident

167+ -> m Type

149168lookupVariable currentModule (Qualified moduleName var) = do

150169 env <- getEnv

151170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do

153172 Just (ty, _, _) -> return ty

154173

155174-- | Lookup the visibility of a value by name in the @Environment@

156−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

175+getVisibility

176+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

177+ => ModuleName

178+ -> Qualified Ident

179+ -> m NameVisibility

157180getVisibility currentModule (Qualified moduleName var) = do

158181 env <- getEnv

159182 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do

161184 Just (_, _, vis) -> return vis

162185

163186-- | Assert that a name is visible

164−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

187+checkVisibility

188+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

189+ => ModuleName

190+ -> Qualified Ident

191+ -> m ()

165192checkVisibility currentModule name@(Qualified _ var) = do

166193 vis <- getVisibility currentModule name

167194 case vis of

@@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do

169196 _ -> return ()

170197

171198-- | Lookup the kind of a type by name in the @Environment@

172−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

199+lookupTypeVariable

200+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

201+ => ModuleName

202+ -> Qualified (ProperName 'TypeName)

203+ -> m Kind

173204lookupTypeVariable currentModule (Qualified moduleName name) = do

174205 env <- getEnv

175206 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

src/Language/PureScript/TypeChecker/Types.hs+11−6

@@ -468,11 +468,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

468468-- |

469469-- Check the type of a value

470470--

471−check' :: forall m.

472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

473− Expr ->

474− Type ->

475− m Expr

471+check'

472+ :: forall m

473+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

474+ => Expr

475+ -> Type

476+ -> m Expr

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

477478 scope <- newSkolemScope

478479 sko <- newSkolemConstant

@@ -492,7 +493,11 @@ check' val t@(ConstrainedType constraints ty) = do

492493 where

493494 -- | Add a dictionary for the constraint to the scope, and dictionaries

494495 -- for all implied superclass instances.

495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]

496+ newDictionaries

497+ :: [(Qualified (ProperName 'ClassName), Integer)]

498+ -> Qualified Ident

499+ -> (Qualified (ProperName 'ClassName), [Type])

500+ -> m [TypeClassDictionaryInScope]

496501 newDictionaries path name (className, instanceTy) = do

497502 tcs <- gets (typeClasses . checkEnv)

498503 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

src/Language/PureScript/TypeClassDictionaries.hs+5−22

@@ -1,23 +1,5 @@

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

2−--

3−-- Module : Language.PureScript.TypeClassDictionaries

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

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

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

16−

171module Language.PureScript.TypeClassDictionaries where

182

19−import Data.Data

20−

213import Language.PureScript.Names

224import Language.PureScript.Types

235

@@ -29,14 +11,15 @@ data TypeClassDictionaryInScope

2911 -- | The identifier with which the dictionary can be accessed at runtime

3012 tcdName :: Qualified Ident

3113 -- | How to obtain this instance via superclass relationships

32− , tcdPath :: [(Qualified ProperName, Integer)]

14+ , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

3315 -- | The name of the type class to which this type class instance applies

34− , tcdClassName :: Qualified ProperName

16+ , tcdClassName :: Qualified (ProperName 'ClassName)

3517 -- | The types to which this type class instance applies

3618 , tcdInstanceTypes :: [Type]

3719 -- | Type class dependencies which must be satisfied to construct this dictionary

3820 , tcdDependencies :: Maybe [Constraint]

39− } deriving (Show, Read, Data, Typeable)

21+ }

22+ deriving (Show, Read)

4023

4124-- |

4225-- A simplified representation of expressions which are used to represent type

@@ -58,5 +41,5 @@ data DictionaryValue

5841 -- |

5942 -- A subclass dictionary

6043 --

61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

44+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer

6245 deriving (Show, Read, Ord, Eq)

src/Language/PureScript/Types.hs+9−21

@@ -1,28 +1,14 @@

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

2−--

3−-- Module : Language.PureScript.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Data types for types

13−--

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

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

171{-# LANGUAGE GeneralizedNewtypeDeriving #-}

182{-# LANGUAGE TemplateHaskell #-}

193

4+-- |

5+-- Data types for types

6+--

207module Language.PureScript.Types where

218

229import Prelude ()

2310import Prelude.Compat

2411

25−import Data.Data

2612import Data.List (nub)

2713import Data.Maybe (fromMaybe)

2814import qualified Data.Aeson as A

@@ -39,7 +25,8 @@ import Language.PureScript.AST.SourcePos

3925-- |

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

4127--

42−newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)

28+newtype SkolemScope = SkolemScope { runSkolemScope :: Int }

29+ deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)

4330

4431-- |

4532-- The type of types

@@ -60,7 +47,7 @@ data Type

6047 -- |

6148 -- A type constructor

6249 --

63− | TypeConstructor (Qualified ProperName)

50+ | TypeConstructor (Qualified (ProperName 'TypeName))

6451 -- |

6552 -- A type application

6653 --

@@ -101,12 +88,13 @@ data Type

10188 -- |

10289 -- A placeholder used in pretty printing

10390 --

104− | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)

91+ | PrettyPrintForAll [String] Type

92+ deriving (Show, Read, Eq, Ord)

10593

10694-- |

10795-- A typeclass constraint

10896--

109−type Constraint = (Qualified ProperName, [Type])

97+type Constraint = (Qualified (ProperName 'ClassName), [Type])

11098

11199$(A.deriveJSON A.defaultOptions ''Type)

112100

tests/Main.hs+18−2

@@ -30,6 +30,7 @@

3030-- -- @shouldFailWith TypesDoNotUnify

3131-- -- @shouldFailWith TypesDoNotUnify

3232-- -- @shouldFailWith TransitiveExportError

33+--

3334

3435module Main (main) where

3536

@@ -39,6 +40,7 @@ import Prelude.Compat

3940import qualified Language.PureScript as P

4041import qualified Language.PureScript.CodeGen.JS as J

4142import qualified Language.PureScript.CoreFn as CF

43+import qualified Language.PureScript.Docs as Docs

4244

4345import Data.Char (isSpace)

4446import Data.Maybe (mapMaybe, fromMaybe)

@@ -69,6 +71,7 @@ import Text.Parsec (ParseError)

6971

7072import TestsSetup

7173import TestPscPublish

74+import qualified TestDocs

7275

7376modulesDir :: FilePath

7477modulesDir = ".test_modules" </> "node_modules"

@@ -172,8 +175,20 @@ assertDoesNotCompile inputFiles foreigns = do

172175

173176main :: IO ()

174177main = do

178+ heading "Main compiler test suite"

175179 testCompiler

176− testPscPublish

180+ heading "Documentation test suite"

181+ TestDocs.main

182+ -- heading "psc-publish test suite"

183+ -- testPscPublish

184+

185+ where

186+ heading msg = do

187+ putStrLn ""

188+ putStrLn $ replicate 79 '#'

189+ putStrLn $ "# " ++ msg

190+ putStrLn $ replicate 79 '#'

191+ putStrLn ""

177192

178193testCompiler :: IO ()

179194testCompiler = do

@@ -201,7 +216,7 @@ testCompiler = do

201216 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

202217

203218 if null failures

204− then exitSuccess

219+ then pure ()

205220 else do

206221 putStrLn "Failures:"

207222 forM_ failures $ \(fp, err) ->

@@ -213,6 +228,7 @@ testPscPublish :: IO ()

213228testPscPublish = do

214229 testPackage "tests/support/prelude"

215230

231+

216232supportModules :: [String]

217233supportModules =

218234 [ "Control.Monad.Eff.Class"

tests/TestDocs.hsnew file+232

@@ -0,0 +1,232 @@

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE ViewPatterns #-}

3+{-# LANGUAGE DataKinds #-}

5+module TestDocs where

7+import Prelude ()

8+import Prelude.Compat

10+import Data.Version (Version(..))

11+

12+import Control.Monad hiding (forM_)

13+import Control.Applicative

14+import Control.Arrow

15+import Data.Maybe (fromMaybe)

16+import Data.List ((\\))

17+import Data.Foldable

18+import Data.Traversable

19+import System.Exit

20+import qualified Text.Parsec as Parsec

21+

22+import qualified Language.PureScript as P

23+import qualified Language.PureScript.Docs as Docs

24+import qualified Language.PureScript.Publish as Publish

25+

26+import qualified TestPscPublish

27+

28+publishOpts :: Publish.PublishOptions

29+publishOpts = Publish.defaultPublishOptions

30+ { Publish.publishGetVersion = return testVersion

31+ , Publish.publishWorkingTreeDirty = return ()

32+ }

33+ where testVersion = ("v999.0.0", Version [999,0,0] [])

34+

35+main :: IO ()

36+main = do

37+ TestPscPublish.pushd "examples/docs" $ do

38+ Docs.Package{..} <- Publish.preparePackage publishOpts

39+ forM_ testCases $ \(mn, pragmas) ->

40+ let mdl = takeJust ("module not found in docs: " ++ mn)

41+ (find ((==) mn . Docs.modName) pkgModules)

42+ in forM_ pragmas (flip runAssertionIO mdl)

43+

44+takeJust :: String -> Maybe a -> a

45+takeJust msg = maybe (error msg) id

46+

47+data Assertion

48+ -- | Assert that a particular declaration is documented with the given

49+ -- children

50+ = ShouldBeDocumented P.ModuleName String [String]

51+ -- | Assert that a particular declaration is not documented

52+ | ShouldNotBeDocumented P.ModuleName String

53+ -- | Assert that a particular declaration exists, but without a particular

54+ -- child.

55+ | ChildShouldNotBeDocumented P.ModuleName String String

56+ -- | Assert that a particular declaration has a particular type class

57+ -- constraint.

58+ | ShouldBeConstrained P.ModuleName String String

59+ deriving (Show)

60+

61+data AssertionFailure

62+ -- | A declaration was not documented, but should have been

63+ = NotDocumented P.ModuleName String

64+ -- | A child declaration was not documented, but should have been

65+ | ChildrenNotDocumented P.ModuleName String [String]

66+ -- | A declaration was documented, but should not have been

67+ | Documented P.ModuleName String

68+ -- | A child declaration was documented, but should not have been

69+ | ChildDocumented P.ModuleName String String

70+ -- | A constraint was missing.

71+ | ConstraintMissing P.ModuleName String String

72+ -- | A declaration had the wrong "type" (ie, value, type, type class)

73+ -- Fields: declaration title, expected "type", actual "type".

74+ | WrongDeclarationType P.ModuleName String String String

75+ deriving (Show)

76+

77+data AssertionResult

78+ = Pass

79+ | Fail AssertionFailure

80+ deriving (Show)

81+

82+runAssertion :: Assertion -> Docs.Module -> AssertionResult

83+runAssertion assertion Docs.Module{..} =

84+ case assertion of

85+ ShouldBeDocumented mn decl children ->

86+ case findChildren decl (declarationsFor mn) of

87+ Nothing ->

88+ Fail (NotDocumented mn decl)

89+ Just actualChildren ->

90+ case children \\ actualChildren of

91+ [] -> Pass

92+ cs -> Fail (ChildrenNotDocumented mn decl cs)

93+

94+ ShouldNotBeDocumented mn decl ->

95+ case findChildren decl (declarationsFor mn) of

96+ Just _ ->

97+ Fail (Documented mn decl)

98+ Nothing ->

99+ Pass

100+

101+ ChildShouldNotBeDocumented mn decl child ->

102+ case findChildren decl (declarationsFor mn) of

103+ Just children ->

104+ if child `elem` children

105+ then Fail (ChildDocumented mn decl child)

106+ else Pass

107+ Nothing ->

108+ Fail (NotDocumented mn decl)

109+

110+ ShouldBeConstrained mn decl tyClass ->

111+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

112+ Nothing ->

113+ Fail (NotDocumented mn decl)

114+ Just Docs.Declaration{..} ->

115+ case declInfo of

116+ Docs.ValueDeclaration ty ->

117+ if checkConstrained ty tyClass

118+ then Pass

119+ else Fail (ConstraintMissing mn decl tyClass)

120+ _ ->

121+ Fail (WrongDeclarationType mn decl "value"

122+ (Docs.declInfoToString declInfo))

123+

124+ where

125+ declarationsFor mn =

126+ if P.runModuleName mn == modName

127+ then modDeclarations

128+ else fromMaybe [] (lookup mn modReExports)

129+

130+ findChildren title =

131+ fmap childrenTitles . find ((==) title . Docs.declTitle)

132+

133+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren

134+

135+checkConstrained ty tyClass =

136+ -- Note that we don't recurse on ConstrainedType if none of the constraints

137+ -- match; this is by design, as constraints should be moved to the front

138+ -- anyway.

139+ case ty of

140+ P.ConstrainedType cs _ | any (matches tyClass) cs ->

141+ True

142+ P.ForAll _ ty' _ ->

143+ checkConstrained ty' tyClass

144+ _ ->

145+ False

146+ where

147+ matches className =

148+ (==) className . P.runProperName . P.disqualify . fst

149+

150+runAssertionIO :: Assertion -> Docs.Module -> IO ()

151+runAssertionIO assertion mdl = do

152+ putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)

153+ case runAssertion assertion mdl of

154+ Pass -> pure ()

155+ fail -> do

156+ putStrLn (show fail)

157+ exitFailure

158+

159+testCases :: [(String, [Assertion])]

160+testCases =

161+ [ ("Example",

162+ [ -- From dependencies

163+ ShouldBeDocumented (n "Prelude") "Unit" []

164+ , ShouldNotBeDocumented (n "Prelude") "unit"

165+

166+ -- From local files

167+ , ShouldBeDocumented (n "Example2") "one" []

168+ , ShouldNotBeDocumented (n "Example2") "two"

169+ ])

170+ , ("Example2",

171+ [ ShouldBeDocumented (n "Example2") "one" []

172+ , ShouldBeDocumented (n "Example2") "two" []

173+ ])

174+

175+ , ("UTF8",

176+ [ ShouldBeDocumented (n "UTF8") "thing" []

177+ ])

178+

179+ , ("Transitive1",

180+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []

181+ ])

182+

183+ , ("NotAllCtors",

184+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]

185+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"

186+ ])

187+

188+ , ("DuplicateNames",

189+ [ ShouldBeDocumented (n "Prelude") "Unit" []

190+ , ShouldBeDocumented (n "DuplicateNames") "unit" []

191+ , ShouldNotBeDocumented (n "Prelude") "unit"

192+ ])

193+

194+ , ("MultiVirtual",

195+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []

196+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []

197+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []

198+ ])

199+

200+ , ("Clash",

201+ [ ShouldBeDocumented (n "Clash1") "value" []

202+ , ShouldBeDocumented (n "Clash1") "Type" []

203+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]

204+ ])

205+

206+ , ("SolitaryTypeClassMember",

207+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []

208+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"

209+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"

210+ ])

211+

212+ , ("ReExportedTypeClass",

213+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]

214+ ])

215+

216+ , ("TypeClassWithoutMembers",

217+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []

218+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"

219+ ])

220+

221+ -- Remove this after 0.9.

222+ , ("OldOperators",

223+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []

224+ ])

225+

226+ , ("NewOperators",

227+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

228+ ])

229+ ]

230+

231+ where

232+ n = P.moduleNameFromString

tests/TestPscPublish.hs+3−3

@@ -60,6 +60,6 @@ testPackage dir = do

6060 case r of

6161 Pass _ -> pure ()

6262 other -> do

63− hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")

64− hPutStrLn stderr (show other)

65− exitFailure

63+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")

64+ putStrLn (show other)

65+ exitFailure