git.iko.soy/rowtype-yoga/purescript-native
on 4e7cfee help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
416 lines 16 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE OverloadedStrings #-}
7module TestDocs where
9import Prelude ()
10import Prelude.Compat
12import Control.Arrow (first)
13import Control.Monad.IO.Class (liftIO)
15import Data.Foldable
16import Data.List ((\\))
17import Data.Maybe (fromMaybe)
18import Data.Monoid
19import Data.Text (Text)
20import qualified Data.Text as T
21import Data.Time.Clock (getCurrentTime)
22import Data.Version (Version(..))
23import System.Exit
25import qualified Language.PureScript as P
26import qualified Language.PureScript.Docs as Docs
27import Language.PureScript.Docs.AsMarkdown (codeToString)
28import qualified Language.PureScript.Publish as Publish
29import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
31import Web.Bower.PackageMeta (parsePackageName)
33import TestUtils
35publishOpts :: Publish.PublishOptions
36publishOpts = Publish.defaultPublishOptions
37 { Publish.publishGetVersion = return testVersion
38 , Publish.publishGetTagTime = const (liftIO getCurrentTime)
39 , Publish.publishWorkingTreeDirty = return ()
40 }
41 where testVersion = ("v999.0.0", Version [999,0,0] [])
43main :: IO ()
44main = pushd "examples/docs" $ do
45 res <- Publish.preparePackage publishOpts
46 case res of
47 Left e -> Publish.printErrorToStdout e >> exitFailure
48 Right pkg@Docs.Package{..} ->
49 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
50 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
51 (find ((==) mn . Docs.modName) pkgModules)
52 linksCtx = Docs.getLinksContext pkg
53 in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl)
56takeJust :: String -> Maybe a -> a
57takeJust msg = fromMaybe (error msg)
59data Assertion
60 -- | Assert that a particular declaration is documented with the given
61 -- children
62 = ShouldBeDocumented P.ModuleName Text [Text]
63 -- | Assert that a particular declaration is not documented
64 | ShouldNotBeDocumented P.ModuleName Text
65 -- | Assert that a particular declaration exists, but without a particular
66 -- child.
67 | ChildShouldNotBeDocumented P.ModuleName Text Text
68 -- | Assert that a particular declaration has a particular type class
69 -- constraint.
70 | ShouldBeConstrained P.ModuleName Text Text
71 -- | Assert that a particular typeclass declaration has a functional
72 -- dependency list.
73 | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])]
74 -- | Assert that a particular value declaration exists, and its type
75 -- satisfies the given predicate.
76 | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool))
77 -- | Assert that a particular type alias exists, and its corresponding
78 -- type, when rendered, matches a given string exactly
79 -- fields: module, type synonym name, expected type
80 | TypeSynonymShouldRenderAs P.ModuleName Text Text
81 -- | Assert that a documented declaration includes a documentation comment
82 -- containing a particular string
83 | ShouldHaveDocComment P.ModuleName Text Text
84 -- | Assert that there should be some declarations re-exported from a
85 -- particular module in a particular package.
86 | ShouldHaveReExport (Docs.InPackage P.ModuleName)
87 -- | Assert that a link to some specific declaration exists within the
88 -- rendered code for a declaration. Fields are: local module, local
89 -- declaration title, title of linked declaration, namespace of linked
90 -- declaration, destination of link.
91 | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation
92 deriving (Show)
94newtype ShowFn a = ShowFn a
96instance Show (ShowFn a) where
97 show _ = "<function>"
99data AssertionFailure
100 -- | A declaration was not documented, but should have been
101 = NotDocumented P.ModuleName Text
102 -- | A child declaration was not documented, but should have been
103 | ChildrenNotDocumented P.ModuleName Text [Text]
104 -- | A declaration was documented, but should not have been
105 | Documented P.ModuleName Text
106 -- | A child declaration was documented, but should not have been
107 | ChildDocumented P.ModuleName Text Text
108 -- | A constraint was missing.
109 | ConstraintMissing P.ModuleName Text Text
110 -- | A functional dependency was missing.
111 | FunDepMissing P.ModuleName Text [([Text], [Text])]
112 -- | A declaration had the wrong "type" (ie, value, type, type class)
113 -- Fields: declaration title, expected "type", actual "type".
114 | WrongDeclarationType P.ModuleName Text Text Text
115 -- | A value declaration had the wrong type (in the sense of "type
116 -- checking"), eg, because the inferred type was used when the explicit type
117 -- should have been.
118 -- Fields: module name, declaration name, actual type.
119 | ValueDeclarationWrongType P.ModuleName Text P.Type
120 -- | A Type synonym has been rendered in an unexpected format
121 -- Fields: module name, declaration name, expected rendering, actual rendering
122 | TypeSynonymMismatch P.ModuleName Text Text Text
123 -- | A doc comment was not found or did not match what was expected
124 -- Fields: module name, expected substring, actual comments
125 | DocCommentMissing P.ModuleName Text (Maybe Text)
126 -- | A module was missing re-exports from a particular module.
127 -- Fields: module name, expected re-export, actual re-exports.
128 | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
129 -- | Expected to find some other declaration mentioned in this declaration's
130 -- rendered code, but did not find anything.
131 -- Fields: module name, declaration title, title of declaration which was
132 -- expected but not found in.
133 | LinkedDeclarationMissing P.ModuleName Text Text
134 -- | Expected one link location for a declaration mentioned in some other
135 -- declaration's rendered code, but found a different one. Fields: module
136 -- name, title of the local declaration which links to some other
137 -- declaration, title of the linked declaration, expected location, actual
138 -- location.
139 | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation
140 deriving (Show)
142data AssertionResult
143 = Pass
144 | Fail AssertionFailure
145 deriving (Show)
147runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult
148runAssertion assertion linksCtx Docs.Module{..} =
149 case assertion of
150 ShouldBeDocumented mn decl children ->
151 case findChildren decl (declarationsFor mn) of
152 Nothing ->
153 Fail (NotDocumented mn decl)
154 Just actualChildren ->
155 case children \\ actualChildren of
156 [] -> Pass
157 cs -> Fail (ChildrenNotDocumented mn decl cs)
159 ShouldNotBeDocumented mn decl ->
160 case findChildren decl (declarationsFor mn) of
161 Just _ ->
162 Fail (Documented mn decl)
163 Nothing ->
164 Pass
166 ChildShouldNotBeDocumented mn decl child ->
167 case findChildren decl (declarationsFor mn) of
168 Just children ->
169 if child `elem` children
170 then Fail (ChildDocumented mn decl child)
171 else Pass
172 Nothing ->
173 Fail (NotDocumented mn decl)
175 ShouldBeConstrained mn decl tyClass ->
176 findDecl mn decl $ \Docs.Declaration{..} ->
177 case declInfo of
178 Docs.ValueDeclaration ty ->
179 if checkConstrained ty tyClass
180 then Pass
181 else Fail (ConstraintMissing mn decl tyClass)
182 _ ->
183 Fail (WrongDeclarationType mn decl "value"
184 (Docs.declInfoToString declInfo))
186 ShouldHaveFunDeps mn decl fds ->
187 findDecl mn decl $ \Docs.Declaration{..} ->
188 case declInfo of
189 Docs.TypeClassDeclaration _ _ fundeps ->
190 if fundeps == fds
191 then Pass
192 else Fail (FunDepMissing mn decl fds)
193 _ ->
194 Fail (WrongDeclarationType mn decl "value"
195 (Docs.declInfoToString declInfo))
197 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
198 findDecl mn decl $ \Docs.Declaration{..} ->
199 case declInfo of
200 Docs.ValueDeclaration ty ->
201 if tyPredicate ty
202 then Pass
203 else Fail
204 (ValueDeclarationWrongType mn decl ty)
205 _ ->
206 Fail (WrongDeclarationType mn decl "value"
207 (Docs.declInfoToString declInfo))
209 TypeSynonymShouldRenderAs mn decl expected ->
210 findDecl mn decl $ \Docs.Declaration{..} ->
211 case declInfo of
212 Docs.TypeSynonymDeclaration [] ty ->
213 let actual = codeToString (Docs.renderType ty) in
214 if actual == expected
215 then Pass
216 else Fail (TypeSynonymMismatch mn decl expected actual)
217 _ ->
218 Fail (WrongDeclarationType mn decl "synonym"
219 (Docs.declInfoToString declInfo))
221 ShouldHaveDocComment mn decl expected ->
222 findDecl mn decl $ \Docs.Declaration{..} ->
223 if maybe False (expected `T.isInfixOf`) declComments
224 then Pass
225 else Fail (DocCommentMissing mn decl declComments)
227 ShouldHaveReExport reExp ->
228 let
229 reExps = map fst modReExports
230 in
231 if reExp `elem` reExps
232 then Pass
233 else Fail (ReExportMissing modName reExp reExps)
235 ShouldHaveLink mn decl destTitle destNs expectedLoc ->
236 findDecl mn decl $ \decl' ->
237 let
238 rendered = Docs.renderDeclaration decl'
239 in
240 case extract rendered destNs destTitle of
241 Just (Docs.linkLocation -> actualLoc) ->
242 if expectedLoc == actualLoc
243 then Pass
244 else Fail (BadLinkLocation mn decl destTitle expectedLoc actualLoc)
245 Nothing ->
246 Fail (LinkedDeclarationMissing mn decl destTitle)
248 where
249 declarationsFor mn =
250 if mn == modName
251 then modDeclarations
252 else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports))
254 findChildren title =
255 fmap childrenTitles . find ((==) title . Docs.declTitle)
257 findDecl mn title f =
258 case find ((==) title . Docs.declTitle) (declarationsFor mn) of
259 Nothing ->
260 Fail (NotDocumented mn title)
261 Just decl ->
262 f decl
264 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
266 extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink
267 extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink
268 where
269 getLink =
270 Docs.getLink linksCtx (P.moduleNameFromString "$DocsTest") ns title
271 go = \case
272 Docs.Symbol ns' title' (Docs.Link containingMod)
273 | ns' == ns && title' == title -> Just containingMod
274 _ ->
275 Nothing
277checkConstrained :: P.Type -> Text -> Bool
278checkConstrained ty tyClass =
279 -- Note that we don't recurse on ConstrainedType if none of the constraints
280 -- match; this is by design, as constraints should be moved to the front
281 -- anyway.
282 case ty of
283 P.ConstrainedType cs _ | any (matches tyClass) cs ->
284 True
285 P.ForAll _ ty' _ ->
286 checkConstrained ty' tyClass
287 _ ->
288 False
289 where
290 matches className =
291 (==) className . P.runProperName . P.disqualify . P.constraintClass
293runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO ()
294runAssertionIO assertion linksCtx mdl = do
295 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
296 case runAssertion assertion linksCtx mdl of
297 Pass -> pure ()
298 Fail reason -> do
299 putStrLn ("Failed: " <> show reason)
300 exitFailure
302testCases :: [(Text, [Assertion])]
303testCases =
304 [ ("Example",
305 [ -- From dependencies
306 ShouldBeDocumented (n "Prelude") "Unit" []
307 , ShouldNotBeDocumented (n "Prelude") "unit"
309 -- From local files
310 , ShouldBeDocumented (n "Example2") "one" []
311 , ShouldNotBeDocumented (n "Example2") "two"
313 -- Re-exports
314 , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude"))
315 , ShouldHaveReExport (Docs.Local (n "Example2"))
316 ])
318 , ("Example2",
319 [ ShouldBeDocumented (n "Example2") "one" []
320 , ShouldBeDocumented (n "Example2") "two" []
322 , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim"))
323 ])
325 , ("UTF8",
326 [ ShouldBeDocumented (n "UTF8") "thing" []
327 ])
329 , ("Transitive1",
330 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
331 ])
333 , ("NotAllCtors",
334 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
335 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
336 ])
338 , ("DuplicateNames",
339 [ ShouldBeDocumented (n "Prelude") "Unit" []
340 , ShouldBeDocumented (n "DuplicateNames") "unit" []
341 , ShouldNotBeDocumented (n "Prelude") "unit"
342 ])
344 , ("MultiVirtual",
345 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
346 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
347 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
348 ])
350 , ("Clash",
351 [ ShouldBeDocumented (n "Clash1") "value" []
352 , ShouldBeDocumented (n "Clash1") "Type" []
353 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
354 ])
356 , ("SolitaryTypeClassMember",
357 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
358 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
359 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
360 ])
362 , ("ReExportedTypeClass",
363 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
364 ])
366 , ("TypeClassWithoutMembers",
367 [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" []
368 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
369 ])
371 , ("TypeClassWithFunDeps",
372 [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
373 ])
375 , ("NewOperators",
376 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
377 ])
379 , ("ExplicitTypeSignatures",
380 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
381 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
382 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
383 ])
385 , ("ConstrainedArgument",
386 [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
387 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
388 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"
389 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"
390 ])
392 , ("TypeOpAliases",
393 [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b")
394 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c")
395 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
396 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
397 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
398 ])
400 , ("DocComments",
401 [ ShouldHaveDocComment (n "DocComments") "example" " example == 0"
402 ])
403 ]
405 where
406 n = P.moduleNameFromString
407 pkg str = let Right p = parsePackageName str in p
409 hasTypeVar varName =
410 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
412 isVar varName (P.TypeVar name) | varName == T.unpack name = True
413 isVar _ _ = False
415 renderedType expected =
416 ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected