021a351 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1863 from hdgarrood/infer-docs-types-2

021a351Phil Freeman11 years ago

examples/docs/src/ExplicitTypeSignatures.pursnew file+16

compare with golang

unifiedsplit

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

2+module ExplicitTypeSignatures where

4+-- This should use the explicit type signature so that the type variable name

5+-- is preserved.

6+explicit :: forall something. something -> something

7+explicit x

8+ | true = x

9+ | false = x

10+

11+-- This should use the inferred type.

12+anInt :: _

13+anInt = 0

14+

15+-- This should infer a type.

16+aNumber = 1.0

psc-docs/Main.hs+6−6

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

69 Etags -> dumpTags input dumpEtags

70 Ctags -> dumpTags input dumpCtags

71 Markdown -> do

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

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

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

73+ >>= (fst >>> D.convertModulesInPackage))

74 >>= successOrExit

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)

80+ let (ms', missing) = takeByName ms 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)

84+ let (ms', missing) = takeByName' ms names

85 guardMissing missing

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

@@ -93,12 +93,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

93 where

94 guardMissing [] = return ()

95 guardMissing [mn] = do

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

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

97 exitFailure

98 guardMissing mns = do

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

100 forM_ mns $ \mn ->

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

101+ hPutStrLn stderr (" * " ++ P.runModuleName mn)

102 exitFailure

103

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

purescript.cabal+1−1

@@ -176,7 +176,7 @@ library

176 Language.PureScript.Docs.RenderedCode.Types

177 Language.PureScript.Docs.RenderedCode.Render

178 Language.PureScript.Docs.AsMarkdown

179− Language.PureScript.Docs.ParseAndDesugar

179+ Language.PureScript.Docs.ParseAndBookmark

180 Language.PureScript.Docs.Utils.MonoidExtras

181

182 Language.PureScript.Publish

src/Language/PureScript/Docs.hs+1−1

@@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Types as Docs

11import Language.PureScript.Docs.RenderedCode.Render as Docs

12import Language.PureScript.Docs.Convert as Docs

13import Language.PureScript.Docs.Render as Docs

14−import Language.PureScript.Docs.ParseAndDesugar as Docs

14+import Language.PureScript.Docs.ParseAndBookmark as Docs

src/Language/PureScript/Docs/AsMarkdown.hs+7−9

@@ -31,31 +31,29 @@ import qualified Language.PureScript.Docs.Render as Render

31renderModulesAsMarkdown ::

32 (Functor m, Applicative m,

33 MonadError P.MultipleErrors m) =>

34− P.Env ->

35 [P.Module] ->

34 [P.Module] ->

36 m String

35 m String

37−renderModulesAsMarkdown env =

36+renderModulesAsMarkdown =

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

37+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules

40modulesAsMarkdown :: [Module] -> Docs

39modulesAsMarkdown :: [Module] -> Docs

41modulesAsMarkdown = mapM_ moduleAsMarkdown

40modulesAsMarkdown = mapM_ moduleAsMarkdown

43moduleAsMarkdown :: Module -> Docs

42moduleAsMarkdown :: Module -> Docs

44moduleAsMarkdown Module{..} = do

43moduleAsMarkdown Module{..} = do

45− headerLevel 2 $ "Module " ++ modName

44+ headerLevel 2 $ "Module " ++ P.runModuleName modName

46 spacer

45 spacer

47 for_ modComments tell'

46 for_ modComments tell'

48 mapM_ (declAsMarkdown modName) modDeclarations

47 mapM_ (declAsMarkdown modName) modDeclarations

49 spacer

48 spacer

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

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

51− let modName' = P.runModuleName mn

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

50+ headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"

53 spacer

51 spacer

54− mapM_ (declAsMarkdown modName') decls

52+ mapM_ (declAsMarkdown mn) decls

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

54+declAsMarkdown :: P.ModuleName -> Declaration -> Docs

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

55declAsMarkdown mn decl@Declaration{..} = do

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

56+ let options = defaultRenderTypeOptions { currentModule = Just mn }

59 headerLevel 4 (ticks declTitle)

57 headerLevel 4 (ticks declTitle)

60 spacer

58 spacer

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

@@ -16,12 +16,17 @@ module Language.PureScript.Docs.Convert

16import Prelude ()

17import Prelude.Compat

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

19+import Control.Arrow ((&&&), second)

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

21import Control.Category ((>>>))

20import Control.Category ((>>>))

21+import Control.Monad

22+import Control.Monad.State (runStateT)

23+import Control.Monad.Writer.Strict (runWriterT)

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

22import qualified Data.Map as Map

25import qualified Data.Map as Map

27+import Text.Parsec (eof)

24import qualified Language.PureScript as P

28import qualified Language.PureScript as P

29+import qualified Language.PureScript.Constants as C

26import Language.PureScript.Docs.Types

31import Language.PureScript.Docs.Types

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

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

@@ -33,18 +38,17 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)

33-- documentation.

38-- documentation.

34--

39--

35convertModulesInPackage ::

40convertModulesInPackage ::

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

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

37− P.Env ->

38 [InPackage P.Module] ->

42 [InPackage P.Module] ->

39 m [Module]

43 m [Module]

40−convertModulesInPackage env modules =

44+convertModulesInPackage modules =

41 go modules

45 go modules

42 where

46 where

43 localNames =

47 localNames =

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

48+ map P.getModuleName (takeLocals modules)

45 go =

49 go =

46 map ignorePackage

50 map ignorePackage

47− >>> convertModules env

51+ >>> convertModules

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

52 >>> fmap (filter ((`elem` localNames) . modName))

50-- |

54-- |

@@ -53,35 +57,140 @@ convertModulesInPackage env modules =

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

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

54-- documenting re-exports.

58-- documenting re-exports.

55--

59--

56−-- Preconditions:

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

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

62+-- be included.

57--

63--

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

64+-- For value declarations, if explicit type signatures are omitted, or a

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

65+-- wildcard type is used, then we typecheck the modules and use the inferred

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

66+-- types.

61−-- elaborated first.

62−--

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.

67--

68convertModules ::

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

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

70− P.Env ->

71 [P.Module] ->

70 [P.Module] ->

72 m [Module]

71 m [Module]

73−convertModules env =

72+convertModules =

73+ P.sortModules

74+ >>> fmap (fst >>> map importPrim)

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

75+ >=> convertSorted

76+

77+importPrim :: P.Module -> P.Module

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

76-- |

80-- |

77-- Convert a sorted list of modules.

81-- Convert a sorted list of modules.

78--

82--

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

83+convertSorted ::

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

85+ [P.Module] ->

86+ m [Module]

80−convertSorted env modules =

87+convertSorted modules = do

81− let

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

82− traversalOrder =

89+

83− map P.getModuleName modules

90+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules

84− moduleMap =

91+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)

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

92+

86− in

93+ let traversalOrder = map P.getModuleName modules

87− Map.elems (updateReExports env traversalOrder moduleMap)

94+ pure (Map.elems (updateReExports env traversalOrder moduleMap))

95+

96+-- |

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

98+-- none at all, then typecheck in order to fill them in with the inferred

99+-- types.

100+--

101+typeCheckIfNecessary ::

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

103+ [P.Module] ->

104+ [Module] ->

105+ m [Module]

106+typeCheckIfNecessary modules convertedModules =

107+ if any hasWildcards convertedModules

108+ then go

109+ else pure convertedModules

110+

111+ where

112+ hasWildcards =

113+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations

114+

115+ go = do

116+ checkEnv <- snd <$> typeCheck modules

117+ pure (map (insertValueTypes checkEnv) convertedModules)

118+

119+-- |

120+-- Typechecks all the modules together. Also returns the final 'P.Environment',

121+-- which is useful for adding in inferred types where explicit declarations

122+-- were not provided.

123+--

124+typeCheck ::

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

126+ [P.Module] ->

127+ m ([P.Module], P.Environment)

128+typeCheck =

129+ (P.desugar [] >=> check)

130+ >>> fmap (second P.checkEnv)

131+ >>> P.evalSupplyT 0

132+ >>> ignoreWarnings

133+

134+ where

135+ check ms =

136+ runStateT

137+ (traverse P.typeCheckModule ms)

138+ (P.emptyCheckState P.initEnvironment)

139+

140+ ignoreWarnings =

141+ fmap fst . runWriterT

142+

143+-- |

144+-- Updates all the types of the ValueDeclarations inside the module based on

145+-- their types inside the given Environment.

146+--

147+insertValueTypes ::

148+ P.Environment -> Module -> Module

149+insertValueTypes env m =

150+ m { modDeclarations = map go (modDeclarations m) }

151+ where

152+ go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =

153+ let

154+ ident = parseIdent (declTitle d)

155+ ty = lookupName ident

156+ in

157+ d { declInfo = ValueDeclaration ty }

158+ go other =

159+ other

160+

161+ parseIdent =

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

163+

164+ lookupName name =

165+ let key = (modName m, name)

166+ in case Map.lookup key (P.names env) of

167+ Just (ty, _, _) ->

168+ ty

169+ Nothing ->

170+ err ("name not found: " ++ show key)

171+

172+ err msg =

173+ P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)

174+

175+runParser :: P.TokenParser a -> String -> Either String a

176+runParser p s = either (Left . show) Right $ do

177+ ts <- P.lex "" s

178+ P.runTokenParser "" (p <* eof) ts

179+

180+-- |

181+-- Partially desugar modules so that they are suitable for extracting

182+-- documentation information from.

183+--

184+partiallyDesugar ::

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

186+ [P.Module]

187+ -> m (P.Env, [P.Module])

188+partiallyDesugar = P.evalSupplyT 0 . desugar'

189+ where

190+ desugar' =

191+ traverse P.desugarDoModule

192+ >=> P.desugarCasesModule

193+ >=> P.desugarTypeDeclarationsModule

194+ >=> ignoreWarnings . P.desugarImportsWithEnv []

195+

196+ ignoreWarnings = fmap fst . runWriterT

src/Language/PureScript/Docs/Convert/Single.hs+7−3

@@ -29,7 +29,7 @@ import Language.PureScript.Docs.Types

29--

30convertSingleModule :: P.Module -> Module

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

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

32+ Module moduleName comments (declarations m) []

33 where

34 comments = convertComments coms

35 declarations =

@@ -109,7 +109,7 @@ addDefaultFixity decl@Declaration{..}

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

110

111getDeclarationTitle :: P.Declaration -> Maybe String

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

112+getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

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

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

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

@@ -135,8 +135,12 @@ basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration

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

136

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

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

138+convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

139 basicDeclaration title (ValueDeclaration ty)

140+convertDeclaration (P.ValueDeclaration _ _ _ _) title =

141+ -- If no explicit type declaration was provided, insert a wildcard, so that

142+ -- the actual type will be added during type checking.

143+ basicDeclaration title (ValueDeclaration P.TypeWildcard)

140convertDeclaration (P.ExternDeclaration _ ty) title =

144convertDeclaration (P.ExternDeclaration _ ty) title =

141 basicDeclaration title (ValueDeclaration ty)

145 basicDeclaration title (ValueDeclaration ty)

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

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

src/Language/PureScript/Docs/ParseAndDesugar.hs → src/Language/PureScript/Docs/ParseAndBookmark.hsrenamed+16−53

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

1{-# LANGUAGE TupleSections #-}

2{-# LANGUAGE FlexibleContexts #-}

4−module Language.PureScript.Docs.ParseAndDesugar

4+module Language.PureScript.Docs.ParseAndBookmark

5− ( parseAndDesugar

5+ ( parseAndBookmark

6 ) where

8import Prelude ()

@@ -10,16 +10,13 @@ import Prelude.Compat

11import qualified Data.Map as M

12import Control.Arrow (first)

13−import Control.Monad

15−import Control.Monad.Writer.Strict (runWriterT)

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

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

17import Control.Monad.IO.Class (MonadIO(..))

15import Control.Monad.IO.Class (MonadIO(..))

19import Web.Bower.PackageMeta (PackageName)

17import Web.Bower.PackageMeta (PackageName)

21import qualified Language.PureScript as P

19import qualified Language.PureScript as P

22−import qualified Language.PureScript.Constants as C

23import Language.PureScript.Docs.Types

20import Language.PureScript.Docs.Types

24import Language.PureScript.Docs.Convert (collectBookmarks)

21import Language.PureScript.Docs.Convert (collectBookmarks)

@@ -35,23 +32,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks)

35-- * Parse all of the input and dependency source files

32-- * Parse all of the input and dependency source files

36-- * Associate each dependency module with its package name, thereby

33-- * Associate each dependency module with its package name, thereby

37-- distinguishing these from local modules

34-- distinguishing these from local modules

38−-- * Partially desugar all of the resulting modules (just enough for

39−-- producing documentation from them)

40-- * Collect a list of bookmarks from the whole set of source files

35-- * Collect a list of bookmarks from the whole set of source files

41−-- * Return the desugared modules, the bookmarks, and the imports/exports

36+-- * Return the parsed modules and the bookmarks

42−-- Env (which is needed for producing documentation).

37+parseAndBookmark ::

43−parseAndDesugar ::

44 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

38 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

45 [FilePath]

39 [FilePath]

46 -> [(PackageName, FilePath)]

40 -> [(PackageName, FilePath)]

47− -> m ([InPackage P.Module], [Bookmark], P.Env)

41+ -> m ([InPackage P.Module], [Bookmark])

48−parseAndDesugar inputFiles depsFiles = do

42+parseAndBookmark inputFiles depsFiles = do

49 inputFiles' <- traverse (parseAs Local) inputFiles

43 inputFiles' <- traverse (parseAs Local) inputFiles

50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

44 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

52− ms <- parseFiles (inputFiles' ++ depsFiles')

46+ addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')

53− ms' <- sortModules (map snd ms)

54− desugarWithBookmarks ms ms'

56parseFiles ::

48parseFiles ::

57 (MonadError P.MultipleErrors m, MonadIO m) =>

49 (MonadError P.MultipleErrors m, MonadIO m) =>

@@ -60,29 +52,16 @@ parseFiles ::

60parseFiles =

52parseFiles =

61 throwLeft . P.parseModulesFromFiles fileInfoToString

53 throwLeft . P.parseModulesFromFiles fileInfoToString

63−sortModules ::

55+addBookmarks ::

64− (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>

65− [P.Module]

66− -> m [P.Module]

67−sortModules =

68− fmap fst . throwLeft . sortModules' . map importPrim

69− where

70− sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)

71− sortModules' = P.sortModules

72−

73−desugarWithBookmarks ::

74− (MonadError P.MultipleErrors m, MonadIO m) =>

75 [(FileInfo, P.Module)]

56 [(FileInfo, P.Module)]

76− -> [P.Module]

77− -> m ([InPackage P.Module], [Bookmark], P.Env)

57+ -> ([InPackage P.Module], [Bookmark])

78−desugarWithBookmarks msInfo msSorted = do

58+addBookmarks msInfo =

79− (env, msDesugared) <- throwLeft (desugar msSorted)

59+ let

80−

81− let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

60+ msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

82− msPackages = map (addPackage msDeps) msDesugared

61+ msPackages = map (addPackage msDeps . snd) msInfo

83− bookmarks = concatMap collectBookmarks msPackages

62+ bookmarks = concatMap collectBookmarks msPackages

84−

63+ in

85− return (msPackages, bookmarks, env)

64+ (msPackages, bookmarks)

87throwLeft :: (MonadError l m) => Either l r -> m r

66throwLeft :: (MonadError l m) => Either l r -> m r

88throwLeft = either throwError return

67throwLeft = either throwError return

@@ -100,22 +79,6 @@ fileInfoToString :: FileInfo -> FilePath

100fileInfoToString (Local fn) = fn

79fileInfoToString (Local fn) = fn

101fileInfoToString (FromDep _ fn) = fn

80fileInfoToString (FromDep _ fn) = fn

102

103−importPrim :: P.Module -> P.Module

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

105−

106−desugar ::

107− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

108− [P.Module]

109− -> m (P.Env, [P.Module])

110−desugar = P.evalSupplyT 0 . desugar'

111− where

112− desugar' =

113− traverse P.desugarDoModule

114− >=> P.desugarCasesModule

115− >=> ignoreWarnings . P.desugarImportsWithEnv []

116−

117− ignoreWarnings m = liftM fst (runWriterT m)

118−

119parseFile :: FilePath -> IO (FilePath, String)

82parseFile :: FilePath -> IO (FilePath, String)

120parseFile input' = (,) input' <$> readFile input'

83parseFile input' = (,) input' <$> readFile input'

121

src/Language/PureScript/Docs/Types.hs+3−3

@@ -73,7 +73,7 @@ packageName :: Package a -> PackageName

73packageName = bowerName . pkgMeta

75data Module = Module

76− { modName :: String

76+ { modName :: P.ModuleName

77 , modComments :: Maybe String

78 , modDeclarations :: [Declaration]

79 -- Re-exported values from other modules

@@ -346,7 +346,7 @@ parseVersion' str =

346

347asModule :: Parse PackageError Module

348asModule =

349− Module <$> key "name" asString

349+ Module <$> key "name" (P.moduleNameFromString <$> asString)

350 <*> key "comments" (perhaps asString)

351 <*> key "declarations" (eachInArray asDeclaration)

352 <*> key "reExports" (eachInArray asReExport)

@@ -512,7 +512,7 @@ instance A.ToJSON NotYetKnown where

512

513instance A.ToJSON Module where

514 toJSON Module{..} =

515− A.object [ "name" .= modName

515+ A.object [ "name" .= P.runModuleName modName

516 , "comments" .= modComments

517 , "declarations" .= modDeclarations

518 , "reExports" .= map toObj modReExports

src/Language/PureScript/Publish.hs+4−4

@@ -146,15 +146,15 @@ preparePackage' opts = do

146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

147getModulesAndBookmarks = do

148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

149− (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles

149+ (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles

150

151− case runExcept (D.convertModulesInPackage env modules') of

151+ case runExcept (D.convertModulesInPackage modules') of

152 Right modules -> return (bookmarks, modules)

153 Left err -> userError (CompileError err)

154

155 where

156− parseAndDesugar inputFiles depsFiles = do

156+ parseAndBookmark inputFiles depsFiles = do

157− r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles

157+ r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles

158 case r of

159 Right r' ->

160 return r'

src/Language/PureScript/Sugar/Names.hs+2−1

@@ -17,6 +17,7 @@ import Prelude.Compat

17import Data.List (find, nub)

18import Data.Maybe (fromMaybe, mapMaybe)

20+import Control.Arrow (first)

20import Control.Monad

21import Control.Monad

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

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

22import Control.Monad.Writer (MonadWriter(..), censor)

23import Control.Monad.Writer (MonadWriter(..), censor)

@@ -54,7 +55,7 @@ desugarImportsWithEnv

54desugarImportsWithEnv externs modules = do

55desugarImportsWithEnv externs modules = do

55 env <- silence $ foldM externsEnv primEnv externs

56 env <- silence $ foldM externsEnv primEnv externs

56 modules' <- traverse updateExportRefs modules

57 modules' <- traverse updateExportRefs modules

57− (modules'', env') <- foldM updateEnv ([], env) modules'

58+ (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'

58 (env',) <$> traverse (renameInModule' env') modules''

59 (env',) <$> traverse (renameInModule' env') modules''

59 where

60 where

60 silence :: m a -> m a

61 silence :: m a -> m a

tests/TestDocs.hs+45−4

@@ -12,6 +12,7 @@ import Data.Version (Version(..))

12import Data.Monoid ((<>))

13import Data.Maybe (fromMaybe)

14import Data.List ((\\))

15+import Data.Monoid

15import Data.Foldable

16import Data.Foldable

16import System.Exit

17import System.Exit

@@ -32,8 +33,8 @@ main :: IO ()

32main = do

33main = do

33 pushd "examples/docs" $ do

34 pushd "examples/docs" $ do

34 Docs.Package{..} <- Publish.preparePackage publishOpts

35 Docs.Package{..} <- Publish.preparePackage publishOpts

35− forM_ testCases $ \(mn, pragmas) ->

36+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

36− let mdl = takeJust ("module not found in docs: " ++ mn)

37+ let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)

37 (find ((==) mn . Docs.modName) pkgModules)

38 (find ((==) mn . Docs.modName) pkgModules)

38 in forM_ pragmas (flip runAssertionIO mdl)

39 in forM_ pragmas (flip runAssertionIO mdl)

@@ -52,8 +53,16 @@ data Assertion

52 -- | Assert that a particular declaration has a particular type class

53 -- | Assert that a particular declaration has a particular type class

53 -- constraint.

54 -- constraint.

54 | ShouldBeConstrained P.ModuleName String String

55 | ShouldBeConstrained P.ModuleName String String

56+ -- | Assert that a particular value declaration exists, and its type

57+ -- satisfies the given predicate.

58+ | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

55 deriving (Show)

59 deriving (Show)

61+newtype ShowFn a = ShowFn a

62+

63+instance Show (ShowFn a) where

64+ show _ = "<function>"

65+

57data AssertionFailure

66data AssertionFailure

58 -- | A declaration was not documented, but should have been

67 -- | A declaration was not documented, but should have been

59 = NotDocumented P.ModuleName String

68 = NotDocumented P.ModuleName String

@@ -68,6 +77,11 @@ data AssertionFailure

68 -- | A declaration had the wrong "type" (ie, value, type, type class)

77 -- | A declaration had the wrong "type" (ie, value, type, type class)

69 -- Fields: declaration title, expected "type", actual "type".

78 -- Fields: declaration title, expected "type", actual "type".

70 | WrongDeclarationType P.ModuleName String String String

79 | WrongDeclarationType P.ModuleName String String String

80+ -- | A value declaration had the wrong type (in the sense of "type

81+ -- checking"), eg, because the inferred type was used when the explicit type

82+ -- should have been.

83+ -- Fields: module name, declaration name, actual type.

84+ | ValueDeclarationWrongType P.ModuleName String P.Type

71 deriving (Show)

85 deriving (Show)

73data AssertionResult

87data AssertionResult

@@ -117,9 +131,24 @@ runAssertion assertion Docs.Module{..} =

117 Fail (WrongDeclarationType mn decl "value"

131 Fail (WrongDeclarationType mn decl "value"

118 (Docs.declInfoToString declInfo))

132 (Docs.declInfoToString declInfo))

119

133

134+ ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

135+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

136+ Nothing ->

137+ Fail (NotDocumented mn decl)

138+ Just Docs.Declaration{..} ->

139+ case declInfo of

140+ Docs.ValueDeclaration ty ->

141+ if tyPredicate ty

142+ then Pass

143+ else Fail

144+ (ValueDeclarationWrongType mn decl ty)

145+ _ ->

146+ Fail (WrongDeclarationType mn decl "value"

147+ (Docs.declInfoToString declInfo))

148+

120 where

149 where

121 declarationsFor mn =

150 declarationsFor mn =

122− if P.runModuleName mn == modName

151+ if mn == modName

123 then modDeclarations

152 then modDeclarations

124 else fromMaybe [] (lookup mn modReExports)

153 else fromMaybe [] (lookup mn modReExports)

125

154

@@ -146,7 +175,7 @@ checkConstrained ty tyClass =

146

175

147runAssertionIO :: Assertion -> Docs.Module -> IO ()

176runAssertionIO :: Assertion -> Docs.Module -> IO ()

148runAssertionIO assertion mdl = do

177runAssertionIO assertion mdl = do

149− putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)

178+ putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)

150 case runAssertion assertion mdl of

179 case runAssertion assertion mdl of

151 Pass -> pure ()

180 Pass -> pure ()

152 Fail reason -> do

181 Fail reason -> do

@@ -223,7 +252,19 @@ testCases =

223 , ("NewOperators",

252 , ("NewOperators",

224 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

253 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

225 ])

254 ])

255+

256+ , ("ExplicitTypeSignatures",

257+ [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))

258+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))

259+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))

260+ ])

226 ]

261 ]

227

262

228 where

263 where

229 n = P.moduleNameFromString

264 n = P.moduleNameFromString

265+

266+ hasTypeVar varName =

267+ getAny . P.everythingOnTypes (<>) (Any . isVar varName)

268+

269+ isVar varName (P.TypeVar name) | varName == name = True

270+ isVar _ _ = False