git.iko.soy/rowtype-yoga/purescript-native
on da472aa help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
334 lines 12 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE DataKinds #-}
5module TestDocs where
7import Prelude ()
8import Prelude.Compat
10import Data.Version (Version(..))
12import Data.Monoid
13import Data.Maybe (fromMaybe)
14import Data.List ((\\))
15import Data.Foldable
16import qualified Data.Text as T
17import System.Exit
19import qualified Language.PureScript as P
20import qualified Language.PureScript.Docs as Docs
21import Language.PureScript.Docs.AsMarkdown (codeToString)
22import qualified Language.PureScript.Publish as Publish
23import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
25import TestUtils
27publishOpts :: Publish.PublishOptions
28publishOpts = Publish.defaultPublishOptions
29 { Publish.publishGetVersion = return testVersion
30 , Publish.publishWorkingTreeDirty = return ()
31 }
32 where testVersion = ("v999.0.0", Version [999,0,0] [])
34main :: IO ()
35main = pushd "examples/docs" $ do
36 res <- Publish.preparePackage publishOpts
37 case res of
38 Left e -> Publish.printErrorToStdout e >> exitFailure
39 Right Docs.Package{..} ->
40 forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->
41 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
42 (find ((==) mn . Docs.modName) pkgModules)
43 in forM_ pragmas (`runAssertionIO` mdl)
46takeJust :: String -> Maybe a -> a
47takeJust msg = fromMaybe (error msg)
49data Assertion
50 -- | Assert that a particular declaration is documented with the given
51 -- children
52 = ShouldBeDocumented P.ModuleName String [String]
53 -- | Assert that a particular declaration is not documented
54 | ShouldNotBeDocumented P.ModuleName String
55 -- | Assert that a particular declaration exists, but without a particular
56 -- child.
57 | ChildShouldNotBeDocumented P.ModuleName String String
58 -- | Assert that a particular declaration has a particular type class
59 -- constraint.
60 | ShouldBeConstrained P.ModuleName String String
61 -- | Assert that a particular typeclass declaration has a functional
62 -- dependency list.
63 | ShouldHaveFunDeps P.ModuleName String [([String],[String])]
64 -- | Assert that a particular value declaration exists, and its type
65 -- satisfies the given predicate.
66 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
67 -- | Assert that a particular type alias exists, and its corresponding
68 -- type, when rendered, matches a given string exactly
69 -- fields: module, type synonym name, expected type
70 | TypeSynonymShouldRenderAs P.ModuleName String String
71 deriving (Show)
73newtype ShowFn a = ShowFn a
75instance Show (ShowFn a) where
76 show _ = "<function>"
78data AssertionFailure
79 -- | A declaration was not documented, but should have been
80 = NotDocumented P.ModuleName String
81 -- | A child declaration was not documented, but should have been
82 | ChildrenNotDocumented P.ModuleName String [String]
83 -- | A declaration was documented, but should not have been
84 | Documented P.ModuleName String
85 -- | A child declaration was documented, but should not have been
86 | ChildDocumented P.ModuleName String String
87 -- | A constraint was missing.
88 | ConstraintMissing P.ModuleName String String
89 -- | A functional dependency was missing.
90 | FunDepMissing P.ModuleName String [([String], [String])]
91 -- | A declaration had the wrong "type" (ie, value, type, type class)
92 -- Fields: declaration title, expected "type", actual "type".
93 | WrongDeclarationType P.ModuleName String String String
94 -- | A value declaration had the wrong type (in the sense of "type
95 -- checking"), eg, because the inferred type was used when the explicit type
96 -- should have been.
97 -- Fields: module name, declaration name, actual type.
98 | ValueDeclarationWrongType P.ModuleName String P.Type
99 -- | A Type synonym has been rendered in an unexpected format
100 -- Fields: module name, declaration name, expected rendering, actual rendering
101 | TypeSynonymMismatch P.ModuleName String String String
102 deriving (Show)
104data AssertionResult
105 = Pass
106 | Fail AssertionFailure
107 deriving (Show)
109runAssertion :: Assertion -> Docs.Module -> AssertionResult
110runAssertion assertion Docs.Module{..} =
111 case assertion of
112 ShouldBeDocumented mn decl children ->
113 case findChildren decl (declarationsFor mn) of
114 Nothing ->
115 Fail (NotDocumented mn decl)
116 Just actualChildren ->
117 case children \\ actualChildren of
118 [] -> Pass
119 cs -> Fail (ChildrenNotDocumented mn decl cs)
121 ShouldNotBeDocumented mn decl ->
122 case findChildren decl (declarationsFor mn) of
123 Just _ ->
124 Fail (Documented mn decl)
125 Nothing ->
126 Pass
128 ChildShouldNotBeDocumented mn decl child ->
129 case findChildren decl (declarationsFor mn) of
130 Just children ->
131 if child `elem` children
132 then Fail (ChildDocumented mn decl child)
133 else Pass
134 Nothing ->
135 Fail (NotDocumented mn decl)
137 ShouldBeConstrained mn decl tyClass ->
138 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
139 Nothing ->
140 Fail (NotDocumented mn decl)
141 Just Docs.Declaration{..} ->
142 case declInfo of
143 Docs.ValueDeclaration ty ->
144 if checkConstrained ty tyClass
145 then Pass
146 else Fail (ConstraintMissing mn decl tyClass)
147 _ ->
148 Fail (WrongDeclarationType mn decl "value"
149 (Docs.declInfoToString declInfo))
151 ShouldHaveFunDeps mn decl fds ->
152 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
153 Nothing ->
154 Fail (NotDocumented mn decl)
155 Just Docs.Declaration{..} ->
156 case declInfo of
157 Docs.TypeClassDeclaration _ _ fundeps ->
158 if fundeps == fds
159 then Pass
160 else Fail (FunDepMissing mn decl fds)
161 _ ->
162 Fail (WrongDeclarationType mn decl "value"
163 (Docs.declInfoToString declInfo))
165 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
166 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
167 Nothing ->
168 Fail (NotDocumented mn decl)
169 Just Docs.Declaration{..} ->
170 case declInfo of
171 Docs.ValueDeclaration ty ->
172 if tyPredicate ty
173 then Pass
174 else Fail
175 (ValueDeclarationWrongType mn decl ty)
176 _ ->
177 Fail (WrongDeclarationType mn decl "value"
178 (Docs.declInfoToString declInfo))
180 TypeSynonymShouldRenderAs mn decl expected ->
181 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
182 Nothing ->
183 Fail (NotDocumented mn decl)
184 Just Docs.Declaration{..} ->
185 case declInfo of
186 Docs.TypeSynonymDeclaration [] ty ->
187 let actual = codeToString (Docs.renderType ty) in
188 if actual == expected
189 then Pass
190 else Fail (TypeSynonymMismatch mn decl expected actual)
191 _ ->
192 Fail (WrongDeclarationType mn decl "synonym"
193 (Docs.declInfoToString declInfo))
195 where
196 declarationsFor mn =
197 if mn == modName
198 then modDeclarations
199 else fromMaybe [] (lookup mn modReExports)
201 findChildren title =
202 fmap childrenTitles . find ((==) title . Docs.declTitle)
204 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
206checkConstrained :: P.Type -> String -> Bool
207checkConstrained ty tyClass =
208 -- Note that we don't recurse on ConstrainedType if none of the constraints
209 -- match; this is by design, as constraints should be moved to the front
210 -- anyway.
211 case ty of
212 P.ConstrainedType cs _ | any (matches tyClass) cs ->
213 True
214 P.ForAll _ ty' _ ->
215 checkConstrained ty' tyClass
216 _ ->
217 False
218 where
219 matches className =
220 (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass
222runAssertionIO :: Assertion -> Docs.Module -> IO ()
223runAssertionIO assertion mdl = do
224 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
225 case runAssertion assertion mdl of
226 Pass -> pure ()
227 Fail reason -> do
228 putStrLn ("Failed: " <> show reason)
229 exitFailure
231testCases :: [(String, [Assertion])]
232testCases =
233 [ ("Example",
234 [ -- From dependencies
235 ShouldBeDocumented (n "Prelude") "Unit" []
236 , ShouldNotBeDocumented (n "Prelude") "unit"
238 -- From local files
239 , ShouldBeDocumented (n "Example2") "one" []
240 , ShouldNotBeDocumented (n "Example2") "two"
241 ])
242 , ("Example2",
243 [ ShouldBeDocumented (n "Example2") "one" []
244 , ShouldBeDocumented (n "Example2") "two" []
245 ])
247 , ("UTF8",
248 [ ShouldBeDocumented (n "UTF8") "thing" []
249 ])
251 , ("Transitive1",
252 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
253 ])
255 , ("NotAllCtors",
256 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
257 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
258 ])
260 , ("DuplicateNames",
261 [ ShouldBeDocumented (n "Prelude") "Unit" []
262 , ShouldBeDocumented (n "DuplicateNames") "unit" []
263 , ShouldNotBeDocumented (n "Prelude") "unit"
264 ])
266 , ("MultiVirtual",
267 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
268 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
269 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
270 ])
272 , ("Clash",
273 [ ShouldBeDocumented (n "Clash1") "value" []
274 , ShouldBeDocumented (n "Clash1") "Type" []
275 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
276 ])
278 , ("SolitaryTypeClassMember",
279 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
280 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
281 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
282 ])
284 , ("ReExportedTypeClass",
285 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
286 ])
288 , ("TypeClassWithoutMembers",
289 [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" []
290 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
291 ])
293 , ("TypeClassWithFunDeps",
294 [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
295 ])
297 , ("NewOperators",
298 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
299 ])
301 , ("ExplicitTypeSignatures",
302 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
303 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
304 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
305 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
306 ])
308 , ("ConstrainedArgument",
309 [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
310 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
311 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"
312 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"
313 ])
315 , ("TypeOpAliases",
316 [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b")
317 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c")
318 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
319 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
320 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
321 ])
322 ]
324 where
325 n = P.moduleNameFromString . T.pack
327 hasTypeVar varName =
328 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
330 isVar varName (P.TypeVar name) | varName == T.unpack name = True
331 isVar _ _ = False
333 renderedType expected =
334 ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected