git.iko.soy/rowtype-yoga/purescript-native
on 045e69d help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
273 lines 9.1 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 qualified Language.PureScript.Publish as Publish
21import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
23import TestUtils
25publishOpts :: Publish.PublishOptions
26publishOpts = Publish.defaultPublishOptions
27 { Publish.publishGetVersion = return testVersion
28 , Publish.publishWorkingTreeDirty = return ()
29 }
30 where testVersion = ("v999.0.0", Version [999,0,0] [])
32main :: IO ()
33main = pushd "examples/docs" $ do
34 res <- Publish.preparePackage publishOpts
35 case res of
36 Left e -> Publish.printErrorToStdout e >> exitFailure
37 Right Docs.Package{..} ->
38 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
39 let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
40 (find ((==) mn . Docs.modName) pkgModules)
41 in forM_ pragmas (`runAssertionIO` mdl)
44takeJust :: String -> Maybe a -> a
45takeJust msg = fromMaybe (error msg)
47data 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 -- | Assert that a particular value declaration exists, and its type
60 -- satisfies the given predicate.
61 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
62 deriving (Show)
64newtype ShowFn a = ShowFn a
66instance Show (ShowFn a) where
67 show _ = "<function>"
69data AssertionFailure
70 -- | A declaration was not documented, but should have been
71 = NotDocumented P.ModuleName String
72 -- | A child declaration was not documented, but should have been
73 | ChildrenNotDocumented P.ModuleName String [String]
74 -- | A declaration was documented, but should not have been
75 | Documented P.ModuleName String
76 -- | A child declaration was documented, but should not have been
77 | ChildDocumented P.ModuleName String String
78 -- | A constraint was missing.
79 | ConstraintMissing P.ModuleName String String
80 -- | A declaration had the wrong "type" (ie, value, type, type class)
81 -- Fields: declaration title, expected "type", actual "type".
82 | WrongDeclarationType P.ModuleName String String String
83 -- | A value declaration had the wrong type (in the sense of "type
84 -- checking"), eg, because the inferred type was used when the explicit type
85 -- should have been.
86 -- Fields: module name, declaration name, actual type.
87 | ValueDeclarationWrongType P.ModuleName String P.Type
88 deriving (Show)
90data AssertionResult
91 = Pass
92 | Fail AssertionFailure
93 deriving (Show)
95runAssertion :: Assertion -> Docs.Module -> AssertionResult
96runAssertion assertion Docs.Module{..} =
97 case assertion of
98 ShouldBeDocumented mn decl children ->
99 case findChildren decl (declarationsFor mn) of
100 Nothing ->
101 Fail (NotDocumented mn decl)
102 Just actualChildren ->
103 case children \\ actualChildren of
104 [] -> Pass
105 cs -> Fail (ChildrenNotDocumented mn decl cs)
107 ShouldNotBeDocumented mn decl ->
108 case findChildren decl (declarationsFor mn) of
109 Just _ ->
110 Fail (Documented mn decl)
111 Nothing ->
112 Pass
114 ChildShouldNotBeDocumented mn decl child ->
115 case findChildren decl (declarationsFor mn) of
116 Just children ->
117 if child `elem` children
118 then Fail (ChildDocumented mn decl child)
119 else Pass
120 Nothing ->
121 Fail (NotDocumented mn decl)
123 ShouldBeConstrained mn decl tyClass ->
124 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
125 Nothing ->
126 Fail (NotDocumented mn decl)
127 Just Docs.Declaration{..} ->
128 case declInfo of
129 Docs.ValueDeclaration ty ->
130 if checkConstrained ty tyClass
131 then Pass
132 else Fail (ConstraintMissing mn decl tyClass)
133 _ ->
134 Fail (WrongDeclarationType mn decl "value"
135 (Docs.declInfoToString declInfo))
137 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
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 tyPredicate ty
145 then Pass
146 else Fail
147 (ValueDeclarationWrongType mn decl ty)
148 _ ->
149 Fail (WrongDeclarationType mn decl "value"
150 (Docs.declInfoToString declInfo))
152 where
153 declarationsFor mn =
154 if mn == modName
155 then modDeclarations
156 else fromMaybe [] (lookup mn modReExports)
158 findChildren title =
159 fmap childrenTitles . find ((==) title . Docs.declTitle)
161 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
163checkConstrained :: P.Type -> String -> Bool
164checkConstrained ty tyClass =
165 -- Note that we don't recurse on ConstrainedType if none of the constraints
166 -- match; this is by design, as constraints should be moved to the front
167 -- anyway.
168 case ty of
169 P.ConstrainedType cs _ | any (matches tyClass) cs ->
170 True
171 P.ForAll _ ty' _ ->
172 checkConstrained ty' tyClass
173 _ ->
174 False
175 where
176 matches className =
177 (==) className . P.runProperName . P.disqualify . fst
179runAssertionIO :: Assertion -> Docs.Module -> IO ()
180runAssertionIO assertion mdl = do
181 putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
182 case runAssertion assertion mdl of
183 Pass -> pure ()
184 Fail reason -> do
185 putStrLn ("Failed: " <> show reason)
186 exitFailure
188testCases :: [(String, [Assertion])]
189testCases =
190 [ ("Example",
191 [ -- From dependencies
192 ShouldBeDocumented (n "Prelude") "Unit" []
193 , ShouldNotBeDocumented (n "Prelude") "unit"
195 -- From local files
196 , ShouldBeDocumented (n "Example2") "one" []
197 , ShouldNotBeDocumented (n "Example2") "two"
198 ])
199 , ("Example2",
200 [ ShouldBeDocumented (n "Example2") "one" []
201 , ShouldBeDocumented (n "Example2") "two" []
202 ])
204 , ("UTF8",
205 [ ShouldBeDocumented (n "UTF8") "thing" []
206 ])
208 , ("Transitive1",
209 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
210 ])
212 , ("NotAllCtors",
213 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
214 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
215 ])
217 , ("DuplicateNames",
218 [ ShouldBeDocumented (n "Prelude") "Unit" []
219 , ShouldBeDocumented (n "DuplicateNames") "unit" []
220 , ShouldNotBeDocumented (n "Prelude") "unit"
221 ])
223 , ("MultiVirtual",
224 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
225 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
226 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
227 ])
229 , ("Clash",
230 [ ShouldBeDocumented (n "Clash1") "value" []
231 , ShouldBeDocumented (n "Clash1") "Type" []
232 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
233 ])
235 , ("SolitaryTypeClassMember",
236 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
237 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
238 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
239 ])
241 , ("ReExportedTypeClass",
242 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
243 ])
245 , ("TypeClassWithoutMembers",
246 [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
247 , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
248 ])
250 -- Remove this after 0.9.
251 , ("OldOperators",
252 [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
253 ])
255 , ("NewOperators",
256 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
257 ])
259 , ("ExplicitTypeSignatures",
260 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
261 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
262 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
263 ])
264 ]
266 where
267 n = P.moduleNameFromString
269 hasTypeVar varName =
270 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
272 isVar varName (P.TypeVar name) | varName == name = True
273 isVar _ _ = False