git.iko.soy/rowtype-yoga/purescript-native
on 2f17513 help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
373 lines 14 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE OverloadedStrings #-}
6module TestDocs where
8import Prelude ()
9import Prelude.Compat
11import Control.Arrow (first)
12import Control.Monad.IO.Class (liftIO)
14import Data.Foldable
15import Data.List ((\\))
16import Data.Maybe (fromMaybe)
17import Data.Monoid
18import Data.Text (Text)
19import qualified Data.Text as T
20import Data.Time.Clock (getCurrentTime)
21import Data.Version (Version(..))
22import System.Exit
24import qualified Language.PureScript as P
25import qualified Language.PureScript.Docs as Docs
26import Language.PureScript.Docs.AsMarkdown (codeToString)
27import qualified Language.PureScript.Publish as Publish
28import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
30import Web.Bower.PackageMeta (parsePackageName)
32import TestUtils
34publishOpts :: Publish.PublishOptions
35publishOpts = Publish.defaultPublishOptions
36 { Publish.publishGetVersion = return testVersion
37 , Publish.publishGetTagTime = const (liftIO getCurrentTime)
38 , Publish.publishWorkingTreeDirty = return ()
39 }
40 where testVersion = ("v999.0.0", Version [999,0,0] [])
42main :: IO ()
43main = pushd "examples/docs" $ do
44 res <- Publish.preparePackage publishOpts
45 case res of
46 Left e -> Publish.printErrorToStdout e >> exitFailure
47 Right Docs.Package{..} ->
48 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
49 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
50 (find ((==) mn . Docs.modName) pkgModules)
51 in forM_ pragmas (`runAssertionIO` mdl)
54takeJust :: String -> Maybe a -> a
55takeJust msg = fromMaybe (error msg)
57data Assertion
58 -- | Assert that a particular declaration is documented with the given
59 -- children
60 = ShouldBeDocumented P.ModuleName Text [Text]
61 -- | Assert that a particular declaration is not documented
62 | ShouldNotBeDocumented P.ModuleName Text
63 -- | Assert that a particular declaration exists, but without a particular
64 -- child.
65 | ChildShouldNotBeDocumented P.ModuleName Text Text
66 -- | Assert that a particular declaration has a particular type class
67 -- constraint.
68 | ShouldBeConstrained P.ModuleName Text Text
69 -- | Assert that a particular typeclass declaration has a functional
70 -- dependency list.
71 | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])]
72 -- | Assert that a particular value declaration exists, and its type
73 -- satisfies the given predicate.
74 | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool))
75 -- | Assert that a particular type alias exists, and its corresponding
76 -- type, when rendered, matches a given string exactly
77 -- fields: module, type synonym name, expected type
78 | TypeSynonymShouldRenderAs P.ModuleName Text Text
79 -- | Assert that a documented declaration includes a documentation comment
80 -- containing a particular string
81 | ShouldHaveDocComment P.ModuleName Text Text
82 -- | Assert that there should be some declarations re-exported from a
83 -- particular module in a particular package.
84 | ShouldHaveReExport (Docs.InPackage P.ModuleName)
85 deriving (Show)
87newtype ShowFn a = ShowFn a
89instance Show (ShowFn a) where
90 show _ = "<function>"
92data AssertionFailure
93 -- | A declaration was not documented, but should have been
94 = NotDocumented P.ModuleName Text
95 -- | A child declaration was not documented, but should have been
96 | ChildrenNotDocumented P.ModuleName Text [Text]
97 -- | A declaration was documented, but should not have been
98 | Documented P.ModuleName Text
99 -- | A child declaration was documented, but should not have been
100 | ChildDocumented P.ModuleName Text Text
101 -- | A constraint was missing.
102 | ConstraintMissing P.ModuleName Text Text
103 -- | A functional dependency was missing.
104 | FunDepMissing P.ModuleName Text [([Text], [Text])]
105 -- | A declaration had the wrong "type" (ie, value, type, type class)
106 -- Fields: declaration title, expected "type", actual "type".
107 | WrongDeclarationType P.ModuleName Text Text Text
108 -- | A value declaration had the wrong type (in the sense of "type
109 -- checking"), eg, because the inferred type was used when the explicit type
110 -- should have been.
111 -- Fields: module name, declaration name, actual type.
112 | ValueDeclarationWrongType P.ModuleName Text P.Type
113 -- | A Type synonym has been rendered in an unexpected format
114 -- Fields: module name, declaration name, expected rendering, actual rendering
115 | TypeSynonymMismatch P.ModuleName Text Text Text
116 -- | A doc comment was not found or did not match what was expected
117 -- Fields: module name, expected substring, actual comments
118 | DocCommentMissing P.ModuleName Text (Maybe Text)
119 -- | A module was missing re-exports from a particular module.
120 -- Fields: module name, expected re-export, actual re-exports.
121 | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
122 deriving (Show)
124data AssertionResult
125 = Pass
126 | Fail AssertionFailure
127 deriving (Show)
129runAssertion :: Assertion -> Docs.Module -> AssertionResult
130runAssertion assertion Docs.Module{..} =
131 case assertion of
132 ShouldBeDocumented mn decl children ->
133 case findChildren decl (declarationsFor mn) of
134 Nothing ->
135 Fail (NotDocumented mn decl)
136 Just actualChildren ->
137 case children \\ actualChildren of
138 [] -> Pass
139 cs -> Fail (ChildrenNotDocumented mn decl cs)
141 ShouldNotBeDocumented mn decl ->
142 case findChildren decl (declarationsFor mn) of
143 Just _ ->
144 Fail (Documented mn decl)
145 Nothing ->
146 Pass
148 ChildShouldNotBeDocumented mn decl child ->
149 case findChildren decl (declarationsFor mn) of
150 Just children ->
151 if child `elem` children
152 then Fail (ChildDocumented mn decl child)
153 else Pass
154 Nothing ->
155 Fail (NotDocumented mn decl)
157 ShouldBeConstrained mn decl tyClass ->
158 findDecl mn decl $ \Docs.Declaration{..} ->
159 case declInfo of
160 Docs.ValueDeclaration ty ->
161 if checkConstrained ty tyClass
162 then Pass
163 else Fail (ConstraintMissing mn decl tyClass)
164 _ ->
165 Fail (WrongDeclarationType mn decl "value"
166 (Docs.declInfoToString declInfo))
168 ShouldHaveFunDeps mn decl fds ->
169 findDecl mn decl $ \Docs.Declaration{..} ->
170 case declInfo of
171 Docs.TypeClassDeclaration _ _ fundeps ->
172 if fundeps == fds
173 then Pass
174 else Fail (FunDepMissing mn decl fds)
175 _ ->
176 Fail (WrongDeclarationType mn decl "value"
177 (Docs.declInfoToString declInfo))
179 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
180 findDecl mn decl $ \Docs.Declaration{..} ->
181 case declInfo of
182 Docs.ValueDeclaration ty ->
183 if tyPredicate ty
184 then Pass
185 else Fail
186 (ValueDeclarationWrongType mn decl ty)
187 _ ->
188 Fail (WrongDeclarationType mn decl "value"
189 (Docs.declInfoToString declInfo))
191 TypeSynonymShouldRenderAs mn decl expected ->
192 findDecl mn decl $ \Docs.Declaration{..} ->
193 case declInfo of
194 Docs.TypeSynonymDeclaration [] ty ->
195 let actual = codeToString (Docs.renderType ty) in
196 if actual == expected
197 then Pass
198 else Fail (TypeSynonymMismatch mn decl expected actual)
199 _ ->
200 Fail (WrongDeclarationType mn decl "synonym"
201 (Docs.declInfoToString declInfo))
203 ShouldHaveDocComment mn decl expected ->
204 findDecl mn decl $ \Docs.Declaration{..} ->
205 if maybe False (expected `T.isInfixOf`) declComments
206 then Pass
207 else Fail (DocCommentMissing mn decl declComments)
209 ShouldHaveReExport reExp ->
210 let
211 reExps = map fst modReExports
212 in
213 if reExp `elem` reExps
214 then Pass
215 else Fail (ReExportMissing modName reExp reExps)
217 where
218 declarationsFor mn =
219 if mn == modName
220 then modDeclarations
221 else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports))
223 findChildren title =
224 fmap childrenTitles . find ((==) title . Docs.declTitle)
226 findDecl mn title f =
227 case find ((==) title . Docs.declTitle) (declarationsFor mn) of
228 Nothing ->
229 Fail (NotDocumented mn title)
230 Just decl ->
231 f decl
233 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
235checkConstrained :: P.Type -> Text -> Bool
236checkConstrained ty tyClass =
237 -- Note that we don't recurse on ConstrainedType if none of the constraints
238 -- match; this is by design, as constraints should be moved to the front
239 -- anyway.
240 case ty of
241 P.ConstrainedType cs _ | any (matches tyClass) cs ->
242 True
243 P.ForAll _ ty' _ ->
244 checkConstrained ty' tyClass
245 _ ->
246 False
247 where
248 matches className =
249 (==) className . P.runProperName . P.disqualify . P.constraintClass
251runAssertionIO :: Assertion -> Docs.Module -> IO ()
252runAssertionIO assertion mdl = do
253 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
254 case runAssertion assertion mdl of
255 Pass -> pure ()
256 Fail reason -> do
257 putStrLn ("Failed: " <> show reason)
258 exitFailure
260testCases :: [(Text, [Assertion])]
261testCases =
262 [ ("Example",
263 [ -- From dependencies
264 ShouldBeDocumented (n "Prelude") "Unit" []
265 , ShouldNotBeDocumented (n "Prelude") "unit"
267 -- From local files
268 , ShouldBeDocumented (n "Example2") "one" []
269 , ShouldNotBeDocumented (n "Example2") "two"
271 -- Re-exports
272 , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude"))
273 , ShouldHaveReExport (Docs.Local (n "Example2"))
274 ])
276 , ("Example2",
277 [ ShouldBeDocumented (n "Example2") "one" []
278 , ShouldBeDocumented (n "Example2") "two" []
279 ])
281 , ("UTF8",
282 [ ShouldBeDocumented (n "UTF8") "thing" []
283 ])
285 , ("Transitive1",
286 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
287 ])
289 , ("NotAllCtors",
290 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
291 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
292 ])
294 , ("DuplicateNames",
295 [ ShouldBeDocumented (n "Prelude") "Unit" []
296 , ShouldBeDocumented (n "DuplicateNames") "unit" []
297 , ShouldNotBeDocumented (n "Prelude") "unit"
298 ])
300 , ("MultiVirtual",
301 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
302 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
303 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
304 ])
306 , ("Clash",
307 [ ShouldBeDocumented (n "Clash1") "value" []
308 , ShouldBeDocumented (n "Clash1") "Type" []
309 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
310 ])
312 , ("SolitaryTypeClassMember",
313 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
314 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
315 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
316 ])
318 , ("ReExportedTypeClass",
319 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
320 ])
322 , ("TypeClassWithoutMembers",
323 [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" []
324 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
325 ])
327 , ("TypeClassWithFunDeps",
328 [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
329 ])
331 , ("NewOperators",
332 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
333 ])
335 , ("ExplicitTypeSignatures",
336 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
337 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
338 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
339 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
340 ])
342 , ("ConstrainedArgument",
343 [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
344 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
345 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"
346 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"
347 ])
349 , ("TypeOpAliases",
350 [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b")
351 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c")
352 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
353 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
354 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
355 ])
357 , ("DocComments",
358 [ ShouldHaveDocComment (n "DocComments") "example" " example == 0"
359 ])
360 ]
362 where
363 n = P.moduleNameFromString . T.pack
364 pkg str = let Right p = parsePackageName str in p
366 hasTypeVar varName =
367 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
369 isVar varName (P.TypeVar name) | varName == T.unpack name = True
370 isVar _ _ = False
372 renderedType expected =
373 ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected