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
274
275
276
277
278
279
280
281
282
283
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Language.Haskell.Stylish.Module
( -- * Data types
Module (..)
, ModuleHeader
, Import
, Decls
, Comments
, Lines
, makeModule
-- * Getters
, moduleHeader
, moduleImports
, moduleImportGroups
, moduleDecls
, moduleComments
, moduleLanguagePragmas
, queryModule
, groupByLine
-- * Imports
, canMergeImport
, mergeModuleImport
-- * Annotations
, lookupAnnotation
-- * Internal API getters
, rawComments
, rawImport
, rawModuleAnnotations
, rawModuleDecls
, rawModuleExports
, rawModuleHaddocks
, rawModuleName
) where
--------------------------------------------------------------------------------
import Data.Function ((&), on)
import Data.Functor ((<&>))
import Data.Generics (Typeable, everything, mkQ)
import Data.Maybe (mapMaybe)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (nubBy, sort)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Data (Data)
--------------------------------------------------------------------------------
import qualified ApiAnnotation as GHC
import qualified Lexer as GHC
import GHC.Hs (ImportDecl(..), ImportDeclQualifiedStyle(..))
import qualified GHC.Hs as GHC
import GHC.Hs.Extension (GhcPs)
import GHC.Hs.Decls (LHsDecl)
import Outputable (Outputable)
import SrcLoc (GenLocated(..), RealLocated)
import SrcLoc (RealSrcSpan(..), SrcSpan(..))
import SrcLoc (Located)
import qualified SrcLoc as GHC
import qualified Module as GHC
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.GHC
--------------------------------------------------------------------------------
type Lines = [String]
--------------------------------------------------------------------------------
-- | Concrete module type
data Module = Module
{ parsedComments :: [GHC.RealLocated GHC.AnnotationComment]
, parsedAnnotations :: [(GHC.ApiAnnKey, [GHC.SrcSpan])]
, parsedAnnotSrcs :: Map RealSrcSpan [GHC.AnnKeywordId]
, parsedModule :: GHC.Located (GHC.HsModule GhcPs)
} deriving (Data)
-- | Declarations in module
newtype Decls = Decls [LHsDecl GhcPs]
-- | Import declaration in module
newtype Import = Import { unImport :: ImportDecl GhcPs }
deriving newtype (Outputable)
-- | Returns true if the two import declarations can be merged
canMergeImport :: Import -> Import -> Bool
canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1)
[ (==) `on` unLocated . ideclName
, (==) `on` ideclPkgQual
, (==) `on` ideclSource
, hasMergableQualified `on` ideclQualified
, (==) `on` ideclImplicit
, (==) `on` fmap unLocated . ideclAs
, (==) `on` fmap fst . ideclHiding -- same 'hiding' flags
]
where
hasMergableQualified QualifiedPre QualifiedPost = True
hasMergableQualified QualifiedPost QualifiedPre = True
hasMergableQualified q0 q1 = q0 == q1
instance Eq Import where
i0 == i1 = canMergeImport i0 i1 && hasSameImports (unImport i0) (unImport i1)
where
hasSameImports = (==) `on` fmap snd . ideclHiding
instance Ord Import where
compare (Import i0) (Import i1) =
ideclName i0 `compareOutputable` ideclName i1 <>
fmap showOutputable (ideclPkgQual i0) `compare`
fmap showOutputable (ideclPkgQual i1) <>
compareOutputable i0 i1
-- | Comments associated with module
newtype Comments = Comments [GHC.RealLocated GHC.AnnotationComment]
-- | A module header is its name, exports and haddock docstring
data ModuleHeader = ModuleHeader
{ name :: Maybe (GHC.Located GHC.ModuleName)
, exports :: Maybe (GHC.Located [GHC.LIE GhcPs])
, haddocks :: Maybe GHC.LHsDocString
}
-- | Create a module from GHC internal representations
makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module
makeModule pstate = Module comments annotations annotationMap
where
comments
= sort
. filterRealLocated
$ GHC.comment_q pstate ++ (GHC.annotations_comments pstate >>= snd)
filterRealLocated = mapMaybe \case
GHC.L (GHC.RealSrcSpan s) e -> Just (GHC.L s e)
GHC.L (GHC.UnhelpfulSpan _) _ -> Nothing
annotations
= GHC.annotations pstate
annotationMap
= GHC.annotations pstate
& mapMaybe x
& Map.fromListWith (++)
x = \case
((RealSrcSpan rspan, annot), _) -> Just (rspan, [annot])
_ -> Nothing
-- | Get all declarations in module
moduleDecls :: Module -> Decls
moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule
-- | Get comments in module
moduleComments :: Module -> Comments
moduleComments = Comments . parsedComments
-- | Get module language pragmas
moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty Text)]
moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments
where
toLanguagePragma :: RealLocated GHC.AnnotationComment -> Maybe (RealSrcSpan, NonEmpty Text)
toLanguagePragma = \case
L pos (GHC.AnnBlockComment s) ->
Just (T.pack s)
>>= T.stripPrefix "{-#"
>>= T.stripSuffix "#-}"
<&> T.strip
<&> T.splitAt 8 -- length "LANGUAGE"
<&> fmap (T.splitOn ",")
<&> fmap (fmap T.strip)
<&> fmap (filter (not . T.null))
>>= (\(T.toUpper . T.strip -> lang, xs) -> (lang,) <$> nonEmpty xs)
>>= (\(lang, nel) -> if lang == "LANGUAGE" then Just (pos, nel) else Nothing)
_ -> Nothing
-- | Get module imports
moduleImports :: Module -> [Located Import]
moduleImports m
= parsedModule m
& unLocated
& GHC.hsmodImports
& fmap \(L pos i) -> L pos (Import i)
-- | Get groups of imports from module
moduleImportGroups :: Module -> [NonEmpty (Located Import)]
moduleImportGroups = groupByLine unsafeGetRealSrcSpan . moduleImports
-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'.
groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine f = go [] Nothing
where
go acc _ [] = ne acc
go acc mbCurrentLine (x:xs) =
let
lStart = GHC.srcSpanStartLine (f x)
lEnd = GHC.srcSpanEndLine (f x) in
case mbCurrentLine of
Just lPrevEnd | lPrevEnd + 1 < lStart
-> ne acc ++ go [x] (Just lEnd) xs
_ -> go (acc ++ [x]) (Just lEnd) xs
ne [] = []
ne (x : xs) = [x :| xs]
-- | Merge two import declarations, keeping positions from the first
--
-- As alluded, this highlights an issue with merging imports. The GHC
-- annotation comments aren't attached to any particular AST node. This
-- means that right now, we're manually reconstructing the attachment. By
-- merging two import declarations, we lose that mapping.
--
-- It's not really a big deal if we consider that people don't usually
-- comment imports themselves. It _is_ however, systemic and it'd be better
-- if we processed comments beforehand and attached them to all AST nodes in
-- our own representation.
mergeModuleImport :: Located Import -> Located Import -> Located Import
mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) =
L p0 $ Import i0 { ideclHiding = newImportNames }
where
newImportNames =
case (ideclHiding i0, ideclHiding i1) of
(Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1))
(Nothing, Nothing) -> Nothing
(Just x, Nothing) -> Just x
(Nothing, Just x) -> Just x
merge xs ys
= nubBy ((==) `on` showOutputable) (xs ++ ys)
-- | Get module header
moduleHeader :: Module -> ModuleHeader
moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader
{ name = GHC.hsmodName m
, exports = GHC.hsmodExports m
, haddocks = GHC.hsmodHaddockModHeader m
}
-- | Query for annotations associated with a 'SrcSpan'
lookupAnnotation :: SrcSpan -> Module -> [GHC.AnnKeywordId]
lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m)
lookupAnnotation (UnhelpfulSpan _) _ = []
-- | Query the module AST using @f@
queryModule :: Typeable a => (a -> [b]) -> Module -> [b]
queryModule f = everything (++) (mkQ [] f) . parsedModule
--------------------------------------------------------------------------------
-- | Getter for internal components in imports newtype
rawImport :: Import -> ImportDecl GhcPs
rawImport (Import i) = i
-- | Getter for internal module name representation
rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName)
rawModuleName = name
-- | Getter for internal module exports representation
rawModuleExports :: ModuleHeader -> Maybe (GHC.Located [GHC.LIE GhcPs])
rawModuleExports = exports
-- | Getter for internal module haddocks representation
rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString
rawModuleHaddocks = haddocks
-- | Getter for internal module decls representation
rawModuleDecls :: Decls -> [LHsDecl GhcPs]
rawModuleDecls (Decls xs) = xs
-- | Getter for internal module comments representation
rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment]
rawComments (Comments xs) = xs
-- | Getter for internal module annotation representation
rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])]
rawModuleAnnotations = parsedAnnotations
|