summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Docs/Convert/Single.hs
blob: 84b0b62d2dde5e0b7097516fe3e7f8d97f3481eb (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
  ) where

import Protolude

import Control.Category ((>>>))

import qualified Data.Text as T

import Language.PureScript.Docs.Types
import qualified Language.PureScript 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

-- | 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], 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 declTitle d `elem` parentTitles
        then augmentWith a d
        else d) ds

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

getDeclarationTitle :: P.Declaration -> Maybe Text
getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)
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 (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
getDeclarationTitle _ = Nothing

-- | Create a basic Declaration value.
mkDeclaration :: Text -> DeclarationInfo -> Declaration
mkDeclaration title info =
  Declaration { declTitle      = title
              , declComments   = Nothing
              , declSourceSpan = Nothing
              , declChildren   = []
              , declInfo       = info
              }

basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration title info = Just $ Right $ mkDeclaration title info

convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration
convertDeclaration (P.ValueDeclaration _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
  basicDeclaration title (ValueDeclaration ty)
convertDeclaration P.ValueDeclaration{} title =
  -- If no explicit type declaration was provided, insert a wildcard, so that
  -- the actual type will be added during type checking.
  basicDeclaration title (ValueDeclaration P.TypeWildcard{})
convertDeclaration (P.ExternDeclaration _ ty) title =
  basicDeclaration title (ValueDeclaration ty)
convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
  Just (Right (mkDeclaration title info) { declChildren = children })
  where
  info = DataDeclaration dtype args
  children = map convertCtor ctors
  convertCtor (ctor', tys) =
    ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
convertDeclaration (P.ExternDataDeclaration _ kind') title =
  basicDeclaration title (ExternDataDeclaration kind')
convertDeclaration (P.ExternKindDeclaration _) title =
  basicDeclaration title ExternKindDeclaration
convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
  basicDeclaration title (TypeSynonymDeclaration args ty)
convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =
  Just (Right (mkDeclaration title info) { declChildren = children })
  where
  info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps)
  children = map convertClassMember ds
  convertClassMember (P.PositionedDeclaration _ _ d) =
    convertClassMember d
  convertClassMember (P.TypeDeclaration ident' ty) =
    ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
  convertClassMember _ =
    P.internalError "convertDeclaration: Invalid argument to convertClassMember."
convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
  Just (Left (classNameString : 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 Nothing Nothing (ChildInstance constraints classApp)
  classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =
  Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title =
  Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias)))
convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
  fmap (addComments . addSourceSpan) (convertDeclaration d' title)
  where
  addComments (Right d) =
    Right (d { declComments = convertComments com })
  addComments (Left augment) =
    Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
                           augment)

  addSourceSpan (Right d) =
    Right (d { declSourceSpan = Just srcSpan })
  addSourceSpan (Left augment) =
    Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
                           augment)

  withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d))
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)