summaryrefslogtreecommitdiff
path: root/tests/TestDocs.hs
blob: 91bdf529c338648828f7afe4ba4af39c6f8780f9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}

module TestDocs where

import Prelude ()
import Prelude.Compat

import Data.Version (Version(..))

import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.List ((\\))
import Data.Foldable
import System.Exit

import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
import qualified Language.PureScript.Publish as Publish
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish

import TestUtils

publishOpts :: Publish.PublishOptions
publishOpts = Publish.defaultPublishOptions
  { Publish.publishGetVersion = return testVersion
  , Publish.publishWorkingTreeDirty = return ()
  }
  where testVersion = ("v999.0.0", Version [999,0,0] [])

main :: IO ()
main = pushd "examples/docs" $ do
  res <- Publish.preparePackage publishOpts
  case res of
    Left e -> Publish.printErrorToStdout e >> exitFailure
    Right Docs.Package{..} ->
      forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
        let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
                          (find ((==) mn . Docs.modName) pkgModules)
        in forM_ pragmas (`runAssertionIO` mdl)


takeJust :: String -> Maybe a -> a
takeJust msg = fromMaybe (error msg)

data Assertion
  -- | Assert that a particular declaration is documented with the given
  -- children
  = ShouldBeDocumented P.ModuleName String [String]
  -- | Assert that a particular declaration is not documented
  | ShouldNotBeDocumented P.ModuleName String
  -- | Assert that a particular declaration exists, but without a particular
  -- child.
  | ChildShouldNotBeDocumented P.ModuleName String String
  -- | Assert that a particular declaration has a particular type class
  -- constraint.
  | ShouldBeConstrained P.ModuleName String String
  -- | Assert that a particular value declaration exists, and its type
  -- satisfies the given predicate.
  | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
  deriving (Show)

newtype ShowFn a = ShowFn a

instance Show (ShowFn a) where
  show _ = "<function>"

data AssertionFailure
  -- | A declaration was not documented, but should have been
  = NotDocumented P.ModuleName String
  -- | A child declaration was not documented, but should have been
  | ChildrenNotDocumented P.ModuleName String [String]
  -- | A declaration was documented, but should not have been
  | Documented P.ModuleName String
  -- | A child declaration was documented, but should not have been
  | ChildDocumented P.ModuleName String String
  -- | A constraint was missing.
  | ConstraintMissing P.ModuleName String String
  -- | A declaration had the wrong "type" (ie, value, type, type class)
  -- Fields: declaration title, expected "type", actual "type".
  | WrongDeclarationType P.ModuleName String String String
  -- | A value declaration had the wrong type (in the sense of "type
  -- checking"), eg, because the inferred type was used when the explicit type
  -- should have been.
  -- Fields: module name, declaration name, actual type.
  | ValueDeclarationWrongType P.ModuleName String P.Type
  deriving (Show)

data AssertionResult
  = Pass
  | Fail AssertionFailure
  deriving (Show)

runAssertion :: Assertion -> Docs.Module -> AssertionResult
runAssertion assertion Docs.Module{..} =
  case assertion of
    ShouldBeDocumented mn decl children ->
      case findChildren decl (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn decl)
        Just actualChildren ->
          case children \\ actualChildren of
            [] -> Pass
            cs -> Fail (ChildrenNotDocumented mn decl cs)

    ShouldNotBeDocumented mn decl ->
      case findChildren decl (declarationsFor mn) of
        Just _ ->
          Fail (Documented mn decl)
        Nothing ->
          Pass

    ChildShouldNotBeDocumented mn decl child ->
      case findChildren decl (declarationsFor mn) of
        Just children ->
          if child `elem` children
            then Fail (ChildDocumented mn decl child)
            else Pass
        Nothing ->
          Fail (NotDocumented mn decl)

    ShouldBeConstrained mn decl tyClass ->
      case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn decl)
        Just Docs.Declaration{..} ->
          case declInfo of
            Docs.ValueDeclaration ty ->
              if checkConstrained ty tyClass
                then Pass
                else Fail (ConstraintMissing mn decl tyClass)
            _ ->
              Fail (WrongDeclarationType mn decl "value"
                     (Docs.declInfoToString declInfo))

    ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
      case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn decl)
        Just Docs.Declaration{..} ->
          case declInfo of
            Docs.ValueDeclaration ty ->
              if tyPredicate ty
                then Pass
                else Fail
                  (ValueDeclarationWrongType mn decl ty)
            _ ->
              Fail (WrongDeclarationType mn decl "value"
                     (Docs.declInfoToString declInfo))

  where
  declarationsFor mn =
    if mn == modName
      then modDeclarations
      else fromMaybe [] (lookup mn modReExports)

  findChildren title =
    fmap childrenTitles . find ((==) title . Docs.declTitle)

  childrenTitles = map Docs.cdeclTitle . Docs.declChildren

checkConstrained :: P.Type -> String -> Bool
checkConstrained ty tyClass =
  -- Note that we don't recurse on ConstrainedType if none of the constraints
  -- match; this is by design, as constraints should be moved to the front
  -- anyway.
  case ty of
    P.ConstrainedType cs _ | any (matches tyClass) cs ->
      True
    P.ForAll _ ty' _ ->
      checkConstrained ty' tyClass
    _ ->
      False
  where
  matches className =
    (==) className . P.runProperName . P.disqualify . fst

runAssertionIO :: Assertion -> Docs.Module -> IO ()
runAssertionIO assertion mdl = do
  putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
  case runAssertion assertion mdl of
    Pass -> pure ()
    Fail reason -> do
      putStrLn ("Failed: " <> show reason)
      exitFailure

testCases :: [(String, [Assertion])]
testCases =
  [ ("Example",
      [ -- From dependencies
        ShouldBeDocumented    (n "Prelude") "Unit" []
      , ShouldNotBeDocumented (n "Prelude") "unit"

        -- From local files
      , ShouldBeDocumented    (n "Example2") "one" []
      , ShouldNotBeDocumented (n "Example2") "two"
      ])
  , ("Example2",
      [ ShouldBeDocumented (n "Example2") "one" []
      , ShouldBeDocumented (n "Example2") "two" []
      ])

  , ("UTF8",
      [ ShouldBeDocumented (n "UTF8") "thing" []
      ])

  , ("Transitive1",
      [ ShouldBeDocumented (n "Transitive2") "transitive3" []
      ])

  , ("NotAllCtors",
      [ ShouldBeDocumented         (n "Prelude") "Boolean2" ["True"]
      , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
      ])

  , ("DuplicateNames",
      [ ShouldBeDocumented    (n "Prelude")        "Unit" []
      , ShouldBeDocumented    (n "DuplicateNames") "unit" []
      , ShouldNotBeDocumented (n "Prelude")        "unit"
      ])

  , ("MultiVirtual",
      [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
      , ShouldBeDocumented (n "MultiVirtual2") "bar" []
      , ShouldBeDocumented (n "MultiVirtual2") "baz" []
      ])

  , ("Clash",
      [ ShouldBeDocumented (n "Clash1") "value" []
      , ShouldBeDocumented (n "Clash1") "Type" []
      , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
      ])

  , ("SolitaryTypeClassMember",
      [ ShouldBeDocumented    (n "SomeTypeClass") "member" []
      , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
      , ShouldBeConstrained   (n "SomeTypeClass") "member" "SomeClass"
      ])

  , ("ReExportedTypeClass",
      [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
      ])

  , ("TypeClassWithoutMembers",
      [ ShouldBeDocumented         (n "Intermediate") "SomeClass" []
      , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
      ])

  -- Remove this after 0.9.
  , ("OldOperators",
      [ ShouldBeDocumented  (n "OldOperators2") "(>>)" []
      ])

  , ("NewOperators",
      [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
      ])

  , ("ExplicitTypeSignatures",
      [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
      , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt"    (ShowFn (P.tyInt ==))
      , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber"  (ShowFn (P.tyNumber ==))
      ])
  ]

  where
  n = P.moduleNameFromString

  hasTypeVar varName =
    getAny . P.everythingOnTypes (<>) (Any . isVar varName)

  isVar varName (P.TypeVar name) | varName == name = True
  isVar _ _ = False