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