git.iko.soy/rowtype-yoga/purescript-native
on 36aede6 help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
272 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 (flip runAssertionIO mdl)
43takeJust :: String -> Maybe a -> a
44takeJust msg = fromMaybe (error msg)
46data Assertion
47 -- | Assert that a particular declaration is documented with the given
48 -- children
49 = ShouldBeDocumented P.ModuleName String [String]
50 -- | Assert that a particular declaration is not documented
51 | ShouldNotBeDocumented P.ModuleName String
52 -- | Assert that a particular declaration exists, but without a particular
53 -- child.
54 | ChildShouldNotBeDocumented P.ModuleName String String
55 -- | Assert that a particular declaration has a particular type class
56 -- constraint.
57 | ShouldBeConstrained P.ModuleName String String
58 -- | Assert that a particular value declaration exists, and its type
59 -- satisfies the given predicate.
60 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
61 deriving (Show)
63newtype ShowFn a = ShowFn a
65instance Show (ShowFn a) where
66 show _ = "<function>"
68data AssertionFailure
69 -- | A declaration was not documented, but should have been
70 = NotDocumented P.ModuleName String
71 -- | A child declaration was not documented, but should have been
72 | ChildrenNotDocumented P.ModuleName String [String]
73 -- | A declaration was documented, but should not have been
74 | Documented P.ModuleName String
75 -- | A child declaration was documented, but should not have been
76 | ChildDocumented P.ModuleName String String
77 -- | A constraint was missing.
78 | ConstraintMissing P.ModuleName String String
79 -- | A declaration had the wrong "type" (ie, value, type, type class)
80 -- Fields: declaration title, expected "type", actual "type".
81 | WrongDeclarationType P.ModuleName String String String
82 -- | A value declaration had the wrong type (in the sense of "type
83 -- checking"), eg, because the inferred type was used when the explicit type
84 -- should have been.
85 -- Fields: module name, declaration name, actual type.
86 | ValueDeclarationWrongType P.ModuleName String P.Type
87 deriving (Show)
89data AssertionResult
90 = Pass
91 | Fail AssertionFailure
92 deriving (Show)
94runAssertion :: Assertion -> Docs.Module -> AssertionResult
95runAssertion assertion Docs.Module{..} =
96 case assertion of
97 ShouldBeDocumented mn decl children ->
98 case findChildren decl (declarationsFor mn) of
99 Nothing ->
100 Fail (NotDocumented mn decl)
101 Just actualChildren ->
102 case children \\ actualChildren of
103 [] -> Pass
104 cs -> Fail (ChildrenNotDocumented mn decl cs)
106 ShouldNotBeDocumented mn decl ->
107 case findChildren decl (declarationsFor mn) of
108 Just _ ->
109 Fail (Documented mn decl)
110 Nothing ->
111 Pass
113 ChildShouldNotBeDocumented mn decl child ->
114 case findChildren decl (declarationsFor mn) of
115 Just children ->
116 if child `elem` children
117 then Fail (ChildDocumented mn decl child)
118 else Pass
119 Nothing ->
120 Fail (NotDocumented mn decl)
122 ShouldBeConstrained mn decl tyClass ->
123 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
124 Nothing ->
125 Fail (NotDocumented mn decl)
126 Just Docs.Declaration{..} ->
127 case declInfo of
128 Docs.ValueDeclaration ty ->
129 if checkConstrained ty tyClass
130 then Pass
131 else Fail (ConstraintMissing mn decl tyClass)
132 _ ->
133 Fail (WrongDeclarationType mn decl "value"
134 (Docs.declInfoToString declInfo))
136 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
137 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
138 Nothing ->
139 Fail (NotDocumented mn decl)
140 Just Docs.Declaration{..} ->
141 case declInfo of
142 Docs.ValueDeclaration ty ->
143 if tyPredicate ty
144 then Pass
145 else Fail
146 (ValueDeclarationWrongType mn decl ty)
147 _ ->
148 Fail (WrongDeclarationType mn decl "value"
149 (Docs.declInfoToString declInfo))
151 where
152 declarationsFor mn =
153 if mn == modName
154 then modDeclarations
155 else fromMaybe [] (lookup mn modReExports)
157 findChildren title =
158 fmap childrenTitles . find ((==) title . Docs.declTitle)
160 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
162checkConstrained :: P.Type -> String -> Bool
163checkConstrained ty tyClass =
164 -- Note that we don't recurse on ConstrainedType if none of the constraints
165 -- match; this is by design, as constraints should be moved to the front
166 -- anyway.
167 case ty of
168 P.ConstrainedType cs _ | any (matches tyClass) cs ->
169 True
170 P.ForAll _ ty' _ ->
171 checkConstrained ty' tyClass
172 _ ->
173 False
174 where
175 matches className =
176 (==) className . P.runProperName . P.disqualify . fst
178runAssertionIO :: Assertion -> Docs.Module -> IO ()
179runAssertionIO assertion mdl = do
180 putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
181 case runAssertion assertion mdl of
182 Pass -> pure ()
183 Fail reason -> do
184 putStrLn ("Failed: " <> show reason)
185 exitFailure
187testCases :: [(String, [Assertion])]
188testCases =
189 [ ("Example",
190 [ -- From dependencies
191 ShouldBeDocumented (n "Prelude") "Unit" []
192 , ShouldNotBeDocumented (n "Prelude") "unit"
194 -- From local files
195 , ShouldBeDocumented (n "Example2") "one" []
196 , ShouldNotBeDocumented (n "Example2") "two"
197 ])
198 , ("Example2",
199 [ ShouldBeDocumented (n "Example2") "one" []
200 , ShouldBeDocumented (n "Example2") "two" []
201 ])
203 , ("UTF8",
204 [ ShouldBeDocumented (n "UTF8") "thing" []
205 ])
207 , ("Transitive1",
208 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
209 ])
211 , ("NotAllCtors",
212 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
213 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
214 ])
216 , ("DuplicateNames",
217 [ ShouldBeDocumented (n "Prelude") "Unit" []
218 , ShouldBeDocumented (n "DuplicateNames") "unit" []
219 , ShouldNotBeDocumented (n "Prelude") "unit"
220 ])
222 , ("MultiVirtual",
223 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
224 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
225 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
226 ])
228 , ("Clash",
229 [ ShouldBeDocumented (n "Clash1") "value" []
230 , ShouldBeDocumented (n "Clash1") "Type" []
231 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
232 ])
234 , ("SolitaryTypeClassMember",
235 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
236 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
237 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
238 ])
240 , ("ReExportedTypeClass",
241 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
242 ])
244 , ("TypeClassWithoutMembers",
245 [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
246 , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
247 ])
249 -- Remove this after 0.9.
250 , ("OldOperators",
251 [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
252 ])
254 , ("NewOperators",
255 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
256 ])
258 , ("ExplicitTypeSignatures",
259 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
260 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))
261 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))
262 ])
263 ]
265 where
266 n = P.moduleNameFromString
268 hasTypeVar varName =
269 getAny . P.everythingOnTypes (<>) (Any . isVar varName)
271 isVar varName (P.TypeVar name) | varName == name = True
272 isVar _ _ = False