|
| 1 | +{-# LANGUAGE TupleSections #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE RecordWildCards #-} |
| 4 | +{-# LANGUAGE ViewPatterns #-} |
| 5 | + |
| 6 | +-- | Functions for converting PureScript ASTs into values of the data types |
| 7 | +-- from Language.PureScript.Docs. |
| 8 | + |
| 9 | +module Language.PureScript.Docs.Convert |
| 10 | + ( convertModule |
| 11 | + , collectBookmarks |
| 12 | + ) where |
| 13 | + |
| 14 | +import Control.Monad |
| 15 | +import Control.Category ((>>>)) |
| 16 | +import Data.Either |
| 17 | +import Data.Maybe (mapMaybe, isNothing) |
| 18 | +import Data.List (nub, isPrefixOf, isSuffixOf) |
| 19 | + |
| 20 | +import qualified Language.PureScript as P |
| 21 | + |
| 22 | +import Language.PureScript.Docs.Types |
| 23 | + |
| 24 | +-- | |
| 25 | +-- Convert a single Module. |
| 26 | +-- |
| 27 | +convertModule :: P.Module -> Module |
| 28 | +convertModule m@(P.Module coms moduleName _ _) = |
| 29 | + Module (show moduleName) comments (declarations m) |
| 30 | + where |
| 31 | + comments = convertComments coms |
| 32 | + declarations = |
| 33 | + P.exportedDeclarations |
| 34 | + >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) |
| 35 | + >>> augmentDeclarations |
| 36 | + >>> map addDefaultFixity |
| 37 | + |
| 38 | +-- | The data type for an intermediate stage which we go through during |
| 39 | +-- converting. |
| 40 | +-- |
| 41 | +-- In the first pass, we take all top level declarations in the module, and |
| 42 | +-- collect other information which will later be used to augment the top level |
| 43 | +-- declarations. These two situation correspond to the Right and Left |
| 44 | +-- constructors, respectively. |
| 45 | +-- |
| 46 | +-- In the second pass, we go over all of the Left values and augment the |
| 47 | +-- relevant declarations, leaving only the augmented Right values. |
| 48 | +-- |
| 49 | +-- Note that in the Left case, we provide a [String] as well as augment |
| 50 | +-- information. The [String] value should be a list of titles of declarations |
| 51 | +-- that the augmentation should apply to. For example, for a type instance |
| 52 | +-- declaration, that would be any types or type classes mentioned in the |
| 53 | +-- instance. For a fixity declaration, it would be just the relevant operator's |
| 54 | +-- name. |
| 55 | +type IntermediateDeclaration |
| 56 | + = Either ([String], DeclarationAugment) Declaration |
| 57 | + |
| 58 | +-- | Some data which will be used to augment a Declaration in the |
| 59 | +-- output. |
| 60 | +-- |
| 61 | +-- The AugmentChild constructor allows us to move all children under their |
| 62 | +-- respective parents. It is only necessary for type instance declarations, |
| 63 | +-- since they appear at the top level in the AST, and since they might need to |
| 64 | +-- appear as children in two places (for example, if a data type defined in a |
| 65 | +-- module is an instance of a type class also defined in that module). |
| 66 | +-- |
| 67 | +-- The AugmentFixity constructor allows us to augment operator definitions |
| 68 | +-- with their associativity and precedence. |
| 69 | +data DeclarationAugment |
| 70 | + = AugmentChild ChildDeclaration |
| 71 | + | AugmentFixity P.Fixity |
| 72 | + |
| 73 | +-- | Augment top-level declarations; the second pass. See the comments under |
| 74 | +-- the type synonym IntermediateDeclaration for more information. |
| 75 | +augmentDeclarations :: [IntermediateDeclaration] -> [Declaration] |
| 76 | +augmentDeclarations (partitionEithers -> (augments, toplevels)) = |
| 77 | + foldl go toplevels augments |
| 78 | + where |
| 79 | + go ds (parentTitles, a) = |
| 80 | + map (\d -> |
| 81 | + if declTitle d `elem` parentTitles |
| 82 | + then augmentWith a d |
| 83 | + else d) ds |
| 84 | + |
| 85 | + augmentWith a d = |
| 86 | + case a of |
| 87 | + AugmentChild child -> |
| 88 | + d { declChildren = declChildren d ++ [child] } |
| 89 | + AugmentFixity fixity -> |
| 90 | + d { declFixity = Just fixity } |
| 91 | + |
| 92 | +-- | Add the default operator fixity for operators which do not have associated |
| 93 | +-- fixity declarations. |
| 94 | +-- |
| 95 | +-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully |
| 96 | +-- in 0.8. |
| 97 | +addDefaultFixity :: Declaration -> Declaration |
| 98 | +addDefaultFixity decl@Declaration{..} |
| 99 | + | isOp declTitle && isNothing declFixity = |
| 100 | + decl { declFixity = Just defaultFixity } |
| 101 | + | otherwise = |
| 102 | + decl |
| 103 | + where |
| 104 | + isOp :: String -> Bool |
| 105 | + isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str |
| 106 | + defaultFixity = P.Fixity P.Infixl (-1) |
| 107 | + |
| 108 | +getDeclarationTitle :: P.Declaration -> Maybe String |
| 109 | +getDeclarationTitle (P.TypeDeclaration name _) = Just (show name) |
| 110 | +getDeclarationTitle (P.ExternDeclaration name _) = Just (show name) |
| 111 | +getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name) |
| 112 | +getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name) |
| 113 | +getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name) |
| 114 | +getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name) |
| 115 | +getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name) |
| 116 | +getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")") |
| 117 | +getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d |
| 118 | +getDeclarationTitle _ = Nothing |
| 119 | + |
| 120 | +-- | Create a basic Declaration value. |
| 121 | +mkDeclaration :: String -> DeclarationInfo -> Declaration |
| 122 | +mkDeclaration title info = |
| 123 | + Declaration { declTitle = title |
| 124 | + , declComments = Nothing |
| 125 | + , declSourceSpan = Nothing |
| 126 | + , declChildren = [] |
| 127 | + , declFixity = Nothing |
| 128 | + , declInfo = info |
| 129 | + } |
| 130 | + |
| 131 | +basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration |
| 132 | +basicDeclaration title info = Just $ Right $ mkDeclaration title info |
| 133 | + |
| 134 | +convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration |
| 135 | +convertDeclaration (P.TypeDeclaration _ ty) title = |
| 136 | + basicDeclaration title (ValueDeclaration ty) |
| 137 | +convertDeclaration (P.ExternDeclaration _ ty) title = |
| 138 | + basicDeclaration title (ValueDeclaration ty) |
| 139 | +convertDeclaration (P.DataDeclaration dtype _ args ctors) title = |
| 140 | + Just (Right (mkDeclaration title info) { declChildren = children }) |
| 141 | + where |
| 142 | + info = DataDeclaration dtype args |
| 143 | + children = map convertCtor ctors |
| 144 | + convertCtor (ctor', tys) = |
| 145 | + ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys) |
| 146 | +convertDeclaration (P.ExternDataDeclaration _ kind') title = |
| 147 | + basicDeclaration title (ExternDataDeclaration kind') |
| 148 | +convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = |
| 149 | + basicDeclaration title (TypeSynonymDeclaration args ty) |
| 150 | +convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do |
| 151 | + Just (Right (mkDeclaration title info) { declChildren = children }) |
| 152 | + where |
| 153 | + info = TypeClassDeclaration args implies |
| 154 | + children = map convertClassMember ds |
| 155 | + convertClassMember (P.PositionedDeclaration _ _ d) = |
| 156 | + convertClassMember d |
| 157 | + convertClassMember (P.TypeDeclaration ident' ty) = |
| 158 | + ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty) |
| 159 | + convertClassMember _ = |
| 160 | + error "Invalid argument to convertClassMember." |
| 161 | +convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do |
| 162 | + Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) |
| 163 | + where |
| 164 | + classNameString = unQual className |
| 165 | + typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) |
| 166 | + unQual x = let (P.Qualified _ y) = x in show y |
| 167 | + |
| 168 | + extractProperNames (P.TypeConstructor n) = [unQual n] |
| 169 | + extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n] |
| 170 | + extractProperNames _ = [] |
| 171 | + |
| 172 | + childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) |
| 173 | + classApp = foldl P.TypeApp (P.TypeConstructor className) tys |
| 174 | +convertDeclaration (P.FixityDeclaration fixity _) title = |
| 175 | + Just (Left ([title], AugmentFixity fixity)) |
| 176 | +convertDeclaration (P.PositionedDeclaration srcSpan com d') title = |
| 177 | + fmap (addComments . addSourceSpan) (convertDeclaration d' title) |
| 178 | + where |
| 179 | + addComments (Right d) = |
| 180 | + Right (d { declComments = convertComments com }) |
| 181 | + addComments (Left augment) = |
| 182 | + Left (withAugmentChild (\d -> d { cdeclComments = convertComments com }) |
| 183 | + augment) |
| 184 | + |
| 185 | + addSourceSpan (Right d) = |
| 186 | + Right (d { declSourceSpan = Just srcSpan }) |
| 187 | + addSourceSpan (Left augment) = |
| 188 | + Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) |
| 189 | + augment) |
| 190 | + |
| 191 | + withAugmentChild f (t, a) = |
| 192 | + case a of |
| 193 | + AugmentChild d -> (t, AugmentChild (f d)) |
| 194 | + _ -> (t, a) |
| 195 | +convertDeclaration _ _ = Nothing |
| 196 | + |
| 197 | +convertComments :: [P.Comment] -> Maybe String |
| 198 | +convertComments cs = do |
| 199 | + let raw = concatMap toLines cs |
| 200 | + guard (all hasPipe raw && not (null raw)) |
| 201 | + return (go raw) |
| 202 | + where |
| 203 | + go = unlines . map stripPipes |
| 204 | + |
| 205 | + toLines (P.LineComment s) = [s] |
| 206 | + toLines (P.BlockComment s) = lines s |
| 207 | + |
| 208 | + hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False } |
| 209 | + |
| 210 | + stripPipes = dropPipe . dropWhile (== ' ') |
| 211 | + |
| 212 | + dropPipe ('|':' ':s) = s |
| 213 | + dropPipe ('|':s) = s |
| 214 | + dropPipe s = s |
| 215 | + |
| 216 | +-- | Go through a PureScript module and extract a list of Bookmarks; references |
| 217 | +-- to data types or values, to be used as a kind of index. These are used for |
| 218 | +-- generating links in the HTML documentation, for example. |
| 219 | +collectBookmarks :: InPackage P.Module -> [Bookmark] |
| 220 | +collectBookmarks (Local m) = map Local (collectBookmarks' m) |
| 221 | +collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) |
| 222 | + |
| 223 | +collectBookmarks' :: P.Module -> [(P.ModuleName, String)] |
| 224 | +collectBookmarks' m = |
| 225 | + map (P.getModuleName m, ) |
| 226 | + (mapMaybe getDeclarationTitle |
| 227 | + (P.exportedDeclarations m)) |
| 228 | + |
0 commit comments