git.iko.soy/rowtype-yoga/purescript-native
on cd4c708 help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
309 lines 11 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 System.Exit
18import qualified Language.PureScript as P
19import qualified Language.PureScript.Docs as Docs
20import Language.PureScript.Docs.AsMarkdown (codeToString)
21import qualified Language.PureScript.Publish as Publish
22import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
24import TestUtils
26publishOpts :: Publish.PublishOptions
27publishOpts = Publish.defaultPublishOptions
28 { Publish.publishGetVersion = return testVersion
29 , Publish.publishWorkingTreeDirty = return ()
30 }
31 where testVersion = ("v999.0.0", Version [999,0,0] [])
33main :: IO ()
34main = pushd "examples/docs" $ do
35 res <- Publish.preparePackage publishOpts
36 case res of
37 Left e -> Publish.printErrorToStdout e >> exitFailure
38 Right Docs.Package{..} ->
39 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
40 let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
41 (find ((==) mn . Docs.modName) pkgModules)
42 in forM_ pragmas (`runAssertionIO` mdl)
45takeJust :: String -> Maybe a -> a
46takeJust msg = fromMaybe (error msg)
48data Assertion
49 -- | Assert that a particular declaration is documented with the given
50 -- children
51 = ShouldBeDocumented P.ModuleName String [String]
52 -- | Assert that a particular declaration is not documented
53 | ShouldNotBeDocumented P.ModuleName String
54 -- | Assert that a particular declaration exists, but without a particular
55 -- child.
56 | ChildShouldNotBeDocumented P.ModuleName String String
57 -- | Assert that a particular declaration has a particular type class
58 -- constraint.
59 | ShouldBeConstrained P.ModuleName String String
60 -- | Assert that a particular value declaration exists, and its type
61 -- satisfies the given predicate.
62 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
63 -- | Assert that a particular type alias exists, and its corresponding
64 -- type, when rendered, matches a given string exactly
65 -- fields: module, type synonym name, expected type
66 | TypeSynonymShouldRenderAs P.ModuleName String String
67 deriving (Show)
69newtype ShowFn a = ShowFn a
71instance Show (ShowFn a) where
72 show _ = "<function>"
74data AssertionFailure
75 -- | A declaration was not documented, but should have been
76 = NotDocumented P.ModuleName String
77 -- | A child declaration was not documented, but should have been
78 | ChildrenNotDocumented P.ModuleName String [String]
79 -- | A declaration was documented, but should not have been
80 | Documented P.ModuleName String
81 -- | A child declaration was documented, but should not have been
82 | ChildDocumented P.ModuleName String String
83 -- | A constraint was missing.
84 | ConstraintMissing P.ModuleName String String
85 -- | A declaration had the wrong "type" (ie, value, type, type class)
86 -- Fields: declaration title, expected "type", actual "type".
87 | WrongDeclarationType P.ModuleName String String String
88 -- | A value declaration had the wrong type (in the sense of "type
89 -- checking"), eg, because the inferred type was used when the explicit type
90 -- should have been.
91 -- Fields: module name, declaration name, actual type.
92 | ValueDeclarationWrongType P.ModuleName String P.Type
93 -- | A Type synonym has been rendered in an unexpected format
94 -- Fields: module name, declaration name, expected rendering, actual rendering
95 | TypeSynonymMismatch P.ModuleName String String String
96 deriving (Show)
98data AssertionResult
99 = Pass
100 | Fail AssertionFailure
101 deriving (Show)
103runAssertion :: Assertion -> Docs.Module -> AssertionResult
104runAssertion assertion Docs.Module{..} =
105 case assertion of
106 ShouldBeDocumented mn decl children ->
107 case findChildren decl (declarationsFor mn) of
108 Nothing ->
109 Fail (NotDocumented mn decl)
110 Just actualChildren ->
111 case children \\ actualChildren of
112 [] -> Pass
113 cs -> Fail (ChildrenNotDocumented mn decl cs)
115 ShouldNotBeDocumented mn decl ->
116 case findChildren decl (declarationsFor mn) of
117 Just _ ->
118 Fail (Documented mn decl)
119 Nothing ->
120 Pass
122 ChildShouldNotBeDocumented mn decl child ->
123 case findChildren decl (declarationsFor mn) of
124 Just children ->
125 if child `elem` children
126 then Fail (ChildDocumented mn decl child)
127 else Pass
128 Nothing ->
129 Fail (NotDocumented mn decl)
131 ShouldBeConstrained mn decl tyClass ->
132 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
133 Nothing ->
134 Fail (NotDocumented mn decl)
135 Just Docs.Declaration{..} ->
136 case declInfo of
137 Docs.ValueDeclaration ty ->
138 if checkConstrained ty tyClass
139 then Pass
140 else Fail (ConstraintMissing mn decl tyClass)
141 _ ->
142 Fail (WrongDeclarationType mn decl "value"
143 (Docs.declInfoToString declInfo))
145 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
146 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
147 Nothing ->
148 Fail (NotDocumented mn decl)
149 Just Docs.Declaration{..} ->
150 case declInfo of
151 Docs.ValueDeclaration ty ->
152 if tyPredicate ty
153 then Pass
154 else Fail
155 (ValueDeclarationWrongType mn decl ty)
156 _ ->
157 Fail (WrongDeclarationType mn decl "value"
158 (Docs.declInfoToString declInfo))
160 TypeSynonymShouldRenderAs mn decl expected ->
161 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
162 Nothing ->
163 Fail (NotDocumented mn decl)
164 Just Docs.Declaration{..} ->
165 case declInfo of
166 Docs.TypeSynonymDeclaration [] ty ->
167 let actual = codeToString (Docs.renderType ty) in
168 if actual == expected
169 then Pass
170 else Fail (TypeSynonymMismatch mn decl expected actual)
171 _ ->
172 Fail (WrongDeclarationType mn decl "synonym"
173 (Docs.declInfoToString declInfo))
175 where
176 declarationsFor mn =
177 if mn == modName
178 then modDeclarations
179 else fromMaybe [] (lookup mn modReExports)
181 findChildren title =
182 fmap childrenTitles . find ((==) title . Docs.declTitle)
184 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
186checkConstrained :: P.Type -> String -> Bool
187checkConstrained ty tyClass =
188 -- Note that we don't recurse on ConstrainedType if none of the constraints
189 -- match; this is by design, as constraints should be moved to the front
190 -- anyway.
191 case ty of
192 P.ConstrainedType cs _ | any (matches tyClass) cs ->
193 True
194 P.ForAll _ ty' _ ->
195 checkConstrained ty' tyClass
196 _ ->
197 False
198 where
199 matches className =
200 (==) className . P.runProperName . P.disqualify . P.constraintClass
202runAssertionIO :: Assertion -> Docs.Module -> IO ()
203runAssertionIO assertion mdl = do
204 putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
205 case runAssertion assertion mdl of
206 Pass -> pure ()
207 Fail reason -> do
208 putStrLn ("Failed: " <> show reason)
209 exitFailure
211testCases :: [(String, [Assertion])]
212testCases =
213 [ ("Example",
214 [ -- From dependencies
215 ShouldBeDocumented (n "Prelude") "Unit" []
216 , ShouldNotBeDocumented (n "Prelude") "unit"
218 -- From local files
219 , ShouldBeDocumented (n "Example2") "one" []
220 , ShouldNotBeDocumented (n "Example2") "two"
221 ])
222 , ("Example2",
223 [ ShouldBeDocumented (n "Example2") "one" []
224 , ShouldBeDocumented (n "Example2") "two" []
225 ])
227 , ("UTF8",
228 [ ShouldBeDocumented (n "UTF8") "thing" []
229 ])
231 , ("Transitive1",
232 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
233 ])
235 , ("NotAllCtors",
236 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
237 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
238 ])
240 , ("DuplicateNames",
241 [ ShouldBeDocumented (n "Prelude") "Unit" []
242 , ShouldBeDocumented (n "DuplicateNames") "unit" []
243 , ShouldNotBeDocumented (n "Prelude") "unit"
244 ])
246 , ("MultiVirtual",
247 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
248 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
249 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
250 ])
252 , ("Clash",
253 [ ShouldBeDocumented (n "Clash1") "value" []
254 , ShouldBeDocumented (n "Clash1") "Type" []
255 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
256 ])
258 , ("SolitaryTypeClassMember",
259 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
260 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
261 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
262 ])
264 , ("ReExportedTypeClass",
265 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
266 ])
268 , ("TypeClassWithoutMembers",
269 [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" []
270 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
271 ])
273 , ("NewOperators",
274 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
275 ])
277 , ("ExplicitTypeSignatures",
278 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
279 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
280 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
281 ])
283 , ("ConstrainedArgument",
284 [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
285 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
286 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"
287 , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"
288 ])
290 , ("TypeOpAliases",
291 [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b")
292 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c")
293 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
294 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
295 , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
296 ])
297 ]
299 where
300 n = P.moduleNameFromString
302 hasTypeVar varName =
303 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
305 isVar varName (P.TypeVar name) | varName == name = True
306 isVar _ _ = False
308 renderedType expected =
309 ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected