git.iko.soy/rowtype-yoga/purescript-native
on 2cd12ce help sign in
rowtype-yoga/purescript-native/tests/TestDocs.hs
232 lines 7.3 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 Control.Monad hiding (forM_)
13import Control.Applicative
14import Control.Arrow
15import Data.Maybe (fromMaybe)
16import Data.List ((\\))
17import Data.Foldable
18import Data.Traversable
19import System.Exit
20import qualified Text.Parsec as Parsec
22import qualified Language.PureScript as P
23import qualified Language.PureScript.Docs as Docs
24import qualified Language.PureScript.Publish as Publish
26import qualified TestPscPublish
28publishOpts :: Publish.PublishOptions
29publishOpts = Publish.defaultPublishOptions
30 { Publish.publishGetVersion = return testVersion
31 , Publish.publishWorkingTreeDirty = return ()
32 }
33 where testVersion = ("v999.0.0", Version [999,0,0] [])
35main :: IO ()
36main = do
37 TestPscPublish.pushd "examples/docs" $ do
38 Docs.Package{..} <- Publish.preparePackage publishOpts
39 forM_ testCases $ \(mn, pragmas) ->
40 let mdl = takeJust ("module not found in docs: " ++ mn)
41 (find ((==) mn . Docs.modName) pkgModules)
42 in forM_ pragmas (flip runAssertionIO mdl)
44takeJust :: String -> Maybe a -> a
45takeJust msg = maybe (error msg) id
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 deriving (Show)
61data AssertionFailure
62 -- | A declaration was not documented, but should have been
63 = NotDocumented P.ModuleName String
64 -- | A child declaration was not documented, but should have been
65 | ChildrenNotDocumented P.ModuleName String [String]
66 -- | A declaration was documented, but should not have been
67 | Documented P.ModuleName String
68 -- | A child declaration was documented, but should not have been
69 | ChildDocumented P.ModuleName String String
70 -- | A constraint was missing.
71 | ConstraintMissing P.ModuleName String String
72 -- | A declaration had the wrong "type" (ie, value, type, type class)
73 -- Fields: declaration title, expected "type", actual "type".
74 | WrongDeclarationType P.ModuleName String String String
75 deriving (Show)
77data AssertionResult
78 = Pass
79 | Fail AssertionFailure
80 deriving (Show)
82runAssertion :: Assertion -> Docs.Module -> AssertionResult
83runAssertion assertion Docs.Module{..} =
84 case assertion of
85 ShouldBeDocumented mn decl children ->
86 case findChildren decl (declarationsFor mn) of
87 Nothing ->
88 Fail (NotDocumented mn decl)
89 Just actualChildren ->
90 case children \\ actualChildren of
91 [] -> Pass
92 cs -> Fail (ChildrenNotDocumented mn decl cs)
94 ShouldNotBeDocumented mn decl ->
95 case findChildren decl (declarationsFor mn) of
96 Just _ ->
97 Fail (Documented mn decl)
98 Nothing ->
99 Pass
101 ChildShouldNotBeDocumented mn decl child ->
102 case findChildren decl (declarationsFor mn) of
103 Just children ->
104 if child `elem` children
105 then Fail (ChildDocumented mn decl child)
106 else Pass
107 Nothing ->
108 Fail (NotDocumented mn decl)
110 ShouldBeConstrained mn decl tyClass ->
111 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
112 Nothing ->
113 Fail (NotDocumented mn decl)
114 Just Docs.Declaration{..} ->
115 case declInfo of
116 Docs.ValueDeclaration ty ->
117 if checkConstrained ty tyClass
118 then Pass
119 else Fail (ConstraintMissing mn decl tyClass)
120 _ ->
121 Fail (WrongDeclarationType mn decl "value"
122 (Docs.declInfoToString declInfo))
124 where
125 declarationsFor mn =
126 if P.runModuleName mn == modName
127 then modDeclarations
128 else fromMaybe [] (lookup mn modReExports)
130 findChildren title =
131 fmap childrenTitles . find ((==) title . Docs.declTitle)
133 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
135checkConstrained ty tyClass =
136 -- Note that we don't recurse on ConstrainedType if none of the constraints
137 -- match; this is by design, as constraints should be moved to the front
138 -- anyway.
139 case ty of
140 P.ConstrainedType cs _ | any (matches tyClass) cs ->
141 True
142 P.ForAll _ ty' _ ->
143 checkConstrained ty' tyClass
144 _ ->
145 False
146 where
147 matches className =
148 (==) className . P.runProperName . P.disqualify . fst
150runAssertionIO :: Assertion -> Docs.Module -> IO ()
151runAssertionIO assertion mdl = do
152 putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)
153 case runAssertion assertion mdl of
154 Pass -> pure ()
155 fail -> do
156 putStrLn (show fail)
157 exitFailure
159testCases :: [(String, [Assertion])]
160testCases =
161 [ ("Example",
162 [ -- From dependencies
163 ShouldBeDocumented (n "Prelude") "Unit" []
164 , ShouldNotBeDocumented (n "Prelude") "unit"
166 -- From local files
167 , ShouldBeDocumented (n "Example2") "one" []
168 , ShouldNotBeDocumented (n "Example2") "two"
169 ])
170 , ("Example2",
171 [ ShouldBeDocumented (n "Example2") "one" []
172 , ShouldBeDocumented (n "Example2") "two" []
173 ])
175 , ("UTF8",
176 [ ShouldBeDocumented (n "UTF8") "thing" []
177 ])
179 , ("Transitive1",
180 [ ShouldBeDocumented (n "Transitive2") "transitive3" []
181 ])
183 , ("NotAllCtors",
184 [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
185 , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
186 ])
188 , ("DuplicateNames",
189 [ ShouldBeDocumented (n "Prelude") "Unit" []
190 , ShouldBeDocumented (n "DuplicateNames") "unit" []
191 , ShouldNotBeDocumented (n "Prelude") "unit"
192 ])
194 , ("MultiVirtual",
195 [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
196 , ShouldBeDocumented (n "MultiVirtual2") "bar" []
197 , ShouldBeDocumented (n "MultiVirtual2") "baz" []
198 ])
200 , ("Clash",
201 [ ShouldBeDocumented (n "Clash1") "value" []
202 , ShouldBeDocumented (n "Clash1") "Type" []
203 , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
204 ])
206 , ("SolitaryTypeClassMember",
207 [ ShouldBeDocumented (n "SomeTypeClass") "member" []
208 , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
209 , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
210 ])
212 , ("ReExportedTypeClass",
213 [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
214 ])
216 , ("TypeClassWithoutMembers",
217 [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
218 , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
219 ])
221 -- Remove this after 0.9.
222 , ("OldOperators",
223 [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
224 ])
226 , ("NewOperators",
227 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
228 ])
229 ]
231 where
232 n = P.moduleNameFromString