c3b8b36 · rowtype-yoga/purescript-native

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

Add tests for Language.PureScript.Docs

In particular, tests for documentation for re-exports.

commitc3b8b3642a3e93eab25ad1ca21223c5a07ee263f authorHarry Garrood <harry@garrood.me> dateTue 29 Dec 2015, 14:43 (11 years ago) parent2ed7800

25 files changed+441−4

compare with golang

unifiedsplit

.gitignore+2 .travis.yml+2 core-tests/test-everything.sh+5−3 examples/docs/bower.json+19 examples/docs/bower_components/purescript-prelude/src/Prelude.purs+8 examples/docs/src/Clash.purs+32 examples/docs/src/DuplicateNames.purs+9 examples/docs/src/Example.purs+7 examples/docs/src/Example2.purs+7 examples/docs/src/MultiVirtual.purs+27 examples/docs/src/NewOperators.purs+12 examples/docs/src/NotAllCtors.purs+5 examples/docs/src/OldOperators.purs+10 examples/docs/src/ReExportedTypeClass.purs+5 examples/docs/src/SolitaryTypeClassMember.purs+6 examples/docs/src/SomeTypeClass.purs+5 examples/docs/src/Transitive1.purs+5 examples/docs/src/Transitive2.purs+5 examples/docs/src/Transitive3.purs+4 examples/docs/src/TypeClassWithoutMembers.purs+11 examples/docs/src/UTF8.purs+7 examples/docs/src/Virtual.purs+5 purescript.cabal+4 tests/Main.hs+7−1 tests/TestDocs.hs+232

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

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

purescript.cabal+4

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

@@ -273,6 +276,7 @@ test-suite tests

273276 main-is: Main.hs

274277 other-modules: TestsSetup

275278 TestPscPublish

279+ TestDocs

276280 buildable: True

277281 hs-source-dirs: tests tests/common

278282

tests/Main.hs+7−1

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

@@ -176,6 +179,8 @@ main = do

176179 testCompiler

177180 heading "psc-publish test suite"

178181 testPscPublish

182+ heading "Documentation test suite"

183+ TestDocs.main

179184

180185 where

181186 heading msg = do

@@ -211,7 +216,7 @@ testCompiler = do

211216 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

212217

213218 if null failures

214− then exitSuccess

219+ then pure ()

215220 else do

216221 putStrLn "Failures:"

217222 forM_ failures $ \(fp, err) ->

@@ -223,6 +228,7 @@ testPscPublish :: IO ()

223228testPscPublish = do

224229 testPackage "tests/support/prelude"

225230

231+

226232supportModules :: [String]

227233supportModules =

228234 [ "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