summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Docs/Convert/Single.hs
blob: 60e2ddb0512e3a2ae0b547ec6b27f80662bce9a2 (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
module Language.PureScript.Docs.Convert.Single
  ( convertSingleModule
  , convertComments
  ) where

import Protolude hiding (moduleName)

import Control.Category ((>>>))

import Data.Functor (($>))
import qualified Data.Text as T

import Language.PureScript.Docs.Types

import qualified Language.PureScript.AST as P
import qualified Language.PureScript.Comments as P
import qualified Language.PureScript.Crash as P
import qualified Language.PureScript.Names as P
import qualified Language.PureScript.Types as P

-- |
-- Convert a single Module, but ignore re-exports; any re-exported types or
-- values will not appear in the result.
--
convertSingleModule :: P.Module -> Module
convertSingleModule m@(P.Module _ coms moduleName  _ _) =
  Module moduleName comments (declarations m) []
  where
  comments = convertComments coms
  declarations =
    P.exportedDeclarations
    >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
    >>> augmentDeclarations

-- | Different declarations we can augment
data AugmentType
  = AugmentClass
  -- ^ Augment documentation for a type class
  | AugmentType
  -- ^ Augment documentation for a type constructor

-- | The data type for an intermediate stage which we go through during
-- converting.
--
-- In the first pass, we take all top level declarations in the module, and
-- collect other information which will later be used to augment the top level
-- declarations. These two situation correspond to the Right and Left
-- constructors, respectively.
--
-- In the second pass, we go over all of the Left values and augment the
-- relevant declarations, leaving only the augmented Right values.
--
-- Note that in the Left case, we provide a [Text] as well as augment
-- information. The [Text] value should be a list of titles of declarations
-- that the augmentation should apply to. For example, for a type instance
-- declaration, that would be any types or type classes mentioned in the
-- instance. For a fixity declaration, it would be just the relevant operator's
-- name.
type IntermediateDeclaration
  = Either ([(Text, AugmentType)], DeclarationAugment) Declaration

-- | Some data which will be used to augment a Declaration in the
-- output.
--
-- The AugmentChild constructor allows us to move all children under their
-- respective parents. It is only necessary for type instance declarations,
-- since they appear at the top level in the AST, and since they might need to
-- appear as children in two places (for example, if a data type defined in a
-- module is an instance of a type class also defined in that module).
data DeclarationAugment
  = AugmentChild ChildDeclaration

-- | Augment top-level declarations; the second pass. See the comments under
-- the type synonym IntermediateDeclaration for more information.
augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
augmentDeclarations (partitionEithers -> (augments, toplevels)) =
  foldl' go toplevels augments
  where
  go ds (parentTitles, a) =
    map (\d ->
      if any (matches d) parentTitles
        then augmentWith a d
        else d) ds

  matches d (name, AugmentType) = isType d && declTitle d == name
  matches d (name, AugmentClass) = isTypeClass d && declTitle d == name

  augmentWith (AugmentChild child) d =
    d { declChildren = declChildren d ++ [child] }

getDeclarationTitle :: P.Declaration -> Maybe Text
getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd))
getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name)
getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name)
getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op)
getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op)
getDeclarationTitle _ = Nothing

-- | Create a basic Declaration value.
mkDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Declaration
mkDeclaration (ss, com) title info =
  Declaration { declTitle      = title
              , declComments   = convertComments com
              , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format
              , declChildren   = []
              , declInfo       = info
              }

basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration sa title = Just . Right . mkDeclaration sa title

convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration
convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
  basicDeclaration sa title (ValueDeclaration (ty $> ()))
convertDeclaration (P.ValueDecl sa _ _ _ _) title =
  -- If no explicit type declaration was provided, insert a wildcard, so that
  -- the actual type will be added during type checking.
  basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () Nothing))
convertDeclaration (P.ExternDeclaration sa _ ty) title =
  basicDeclaration sa title (ValueDeclaration (ty $> ()))
convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title =
  Just (Right (mkDeclaration sa title info) { declChildren = children })
  where
  info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args)
  children = map convertCtor ctors
  convertCtor :: P.DataConstructorDeclaration -> ChildDeclaration
  convertCtor P.DataConstructorDeclaration{..} =
    ChildDeclaration (P.runProperName dataCtorName) (convertComments $ snd dataCtorAnn) Nothing (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields))
convertDeclaration (P.ExternDataDeclaration sa _ kind') title =
  basicDeclaration sa title (ExternDataDeclaration (kind' $> ()))
convertDeclaration (P.ExternKindDeclaration sa _) title =
  basicDeclaration sa title ExternKindDeclaration
convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title =
  basicDeclaration sa title (TypeSynonymDeclaration (fmap (fmap (fmap ($> ()))) args) (ty $> ()))
convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title =
  Just (Right (mkDeclaration sa title info) { declChildren = children })
  where
  args' = fmap (fmap (fmap ($> ()))) args
  info = TypeClassDeclaration args' (fmap ($> ()) implies) (convertFundepsToStrings args' fundeps)
  children = map convertClassMember ds
  convertClassMember (P.TypeDeclaration (P.TypeDeclarationData (ss, com) ident' ty)) =
    ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember (ty $> ()))
  convertClassMember _ =
    P.internalError "convertDeclaration: Invalid argument to convertClassMember."
convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title =
  Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl))
  where
  classNameString = unQual className
  typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
  unQual x = let (P.Qualified _ y) = x in P.runProperName y

  extractProperNames (P.TypeConstructor _ n) = [unQual n]
  extractProperNames _ = []

  childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ()))
  classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys
convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
  Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
  Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias)))
convertDeclaration _ _ = Nothing

convertComments :: [P.Comment] -> Maybe Text
convertComments cs = do
  let raw = concatMap toLines cs
  let docs = mapMaybe stripPipe raw
  guard (not (null docs))
  pure (T.unlines docs)

  where
  toLines (P.LineComment s) = [s]
  toLines (P.BlockComment s) = T.lines s

  stripPipe =
    T.dropWhile (== ' ')
    >>> T.stripPrefix "|"
    >>> fmap (dropPrefix " ")

  dropPrefix prefix str =
    fromMaybe str (T.stripPrefix prefix str)