SyntaxColoring.hs 19.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
{- |
    Module      :  $Header$
    Description :  Split module into code fragments
    Copyright   :  (c)  ??  , someone else
                        2014, Björn Peemöller
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module arranges the tokens of the module into different code
    categories for HTML presentation. The parsed and typechecked module
    is used to establish links between used identifiers and their definitions.
-}

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
17
module Html.SyntaxColoring
18
  ( Code (..), TypeUsage (..), ConsUsage (..)
19
  , IdentUsage (..), FuncUsage (..), LabelUsage (..)
20
  , genProgram, code2string, getQualIdent
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21
22
23
  ) where

import Data.Function (on)
24
import Data.List     (intercalate, sortBy)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
25
26
27

import Curry.Base.Ident
import Curry.Base.Position
28
import Curry.Syntax
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
29

30
31
import Base.Messages

32
-- |Type of codes which are distinguished for HTML output
33
data Code
34
35
  = Keyword     String
  | Space       Int
36
  | NewLine
37
38
39
40
41
42
43
44
45
46
47
48
  | Pragma      String
  | TypeCons    TypeUsage  QualIdent
  | DataCons    ConsUsage  QualIdent
  | Function    FuncUsage  QualIdent
  | Identifier  IdentUsage QualIdent
  | Label       LabelUsage QualIdent
  | ModuleName  ModuleIdent
  | Commentary  String
  | NumberCode  String
  | StringCode  String
  | CharCode    String
  | Symbol      String
49
50
    deriving Show

51
52
53
data TypeUsage
  = TypeDeclare
  | TypeRefer
54
  | TypeExport
55
  | TypeImport
56
    deriving Show
57

58
59
60
61
62
63
64
data ConsUsage
  = ConsDeclare
  | ConsPattern
  | ConsCall
  | ConsInfix
  | ConsExport
  | ConsImport
65
    deriving Show
66

67
68
69
70
71
72
73
data FuncUsage
  = FuncDeclare
  | FuncTypeSig
  | FuncCall
  | FuncInfix
  | FuncExport
  | FuncImport
74
    deriving Show
75

76
77
78
79
data IdentUsage
  = IdDeclare -- declare a (type) variable
  | IdRefer   -- refer to a (type) variable
  | IdUnknown -- unknown usage
80
    deriving Show
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
81

82
83
84
85
data LabelUsage
  = LabelDeclare
  | LabelRefer
    deriving Show
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
86

87
88
89
90
91
92
-- @param list with parse-Results with descending quality,
--        e.g. [typingParse, fullParse, parse]
-- @param lex-Result
-- @return program
genProgram :: Module -> [(Position, Token)] -> [Code]
genProgram m toks = tokenToCodes (first "") (idsModule m) toks
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
93

94
95
96
97
98
99
100
-- @param code
-- @return qid if available
getQualIdent :: Code -> Maybe QualIdent
getQualIdent (DataCons    _ qid) = Just qid
getQualIdent (Function    _ qid) = Just qid
getQualIdent (Identifier  _ qid) = Just qid
getQualIdent (TypeCons    _ qid) = Just qid
101
getQualIdent (Label       _ qid) = Just qid
102
103
104
105
106
107
108
109
110
111
112
113
114
getQualIdent  _                  = Nothing

tokenToCodes :: Position -> [Code] -> [(Position, Token)] -> [Code]
tokenToCodes _      _   []                     = []
tokenToCodes curPos ids toks@((pos, tok) : ts)
  -- advance line
  | line curPos < line pos
  = NewLine         : tokenToCodes (nl curPos) ids toks
  -- advance column
  | column curPos < column pos
  = Space colDiff   : tokenToCodes (incr curPos colDiff) ids toks
  | isPragmaToken tok
  = let (pragmas, (end:rest)) = break (isPragmaEnd . snd) toks
115
116
        str = intercalate " " $ map (showToken . snd) (pragmas ++ [end])
    in  Pragma str : tokenToCodes (incr curPos (length str)) ids rest
117
118
119
120
121
122
123
124
125
126
127
128
129
130
  -- no identifier token
  | not (isTokenIdentifier tok)
  = tokenToCode tok : tokenToCodes newPos ids ts
  -- identifier, but no more information
  | null ids
  = tokenToCode tok : tokenToCodes newPos ids ts
  | tokenStr == code2string (head ids)
  = head ids        : tokenToCodes newPos (tail ids) ts
  | otherwise
  = tokenToCodes curPos (tail ids) toks
  where
  colDiff  = column pos - column curPos
  tokenStr = showToken tok
  newPos   = incr curPos (length tokenStr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
131
132

code2string :: Code -> String
133
code2string (Keyword         s) = s
134
code2string (Space           i) = replicate i ' '
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
code2string NewLine             = "\n"
code2string (Pragma          s) = s
code2string (DataCons    _ qid) = idName $ unqualify qid
code2string (TypeCons    _ qid) = idName $ unqualify qid
code2string (Function    _ qid) = idName $ unqualify qid
code2string (Identifier  _ qid) = idName $ unqualify qid
code2string (Label       _ qid) = idName $ unqualify qid
code2string (ModuleName    mid) = moduleName mid
code2string (Commentary      s) = s
code2string (NumberCode      s) = s
code2string (StringCode      s) = s
code2string (CharCode        s) = s
code2string (Symbol          s) = s

tokenToCode :: Token -> Code
tokenToCode tok@(Token cat _)
  | cat `elem` numCategories          = NumberCode (showToken tok)
  | cat == CharTok                    = CharCode   (showToken tok)
  | cat == StringTok                  = StringCode (showToken tok)
  | cat `elem` keywordCategories      = Keyword    (showToken tok)
  | cat `elem` specialIdentCategories = Keyword    (showToken tok)
  | cat `elem` punctuationCategories  = Symbol     (showToken tok)
  | cat `elem` reservedOpsCategories  = Symbol     (showToken tok)
  | cat `elem` commentCategories      = Commentary (showToken tok)
  | cat `elem` identCategories        = Identifier IdUnknown $ qualify $ mkIdent
                                      $ showToken tok
  | cat `elem` whiteSpaceCategories   = Space 0
  | cat `elem` pragmaCategories       = Pragma     (showToken tok)
163
164
  | otherwise                         = internalError $
    "SyntaxColoring.tokenToCode: Unknown token" ++ showToken tok
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

numCategories :: [Category]
numCategories = [IntTok, FloatTok]

keywordCategories :: [Category]
keywordCategories =
  [ KW_case, KW_data, KW_do, KW_else, KW_external, KW_fcase, KW_foreign
  , KW_free, KW_if, KW_import, KW_in, KW_infix, KW_infixl, KW_infixr
  , KW_let, KW_module, KW_newtype, KW_of, KW_then, KW_type, KW_where
  ]

specialIdentCategories :: [Category]
specialIdentCategories =
  [ Id_as, Id_ccall, Id_forall, Id_hiding
  , Id_interface, Id_primitive, Id_qualified ]

punctuationCategories :: [Category]
punctuationCategories =
  [ LeftParen, RightParen, Semicolon, LeftBrace, RightBrace
  , LeftBracket, RightBracket, Comma, Underscore, Backquote ]

reservedOpsCategories :: [Category]
reservedOpsCategories =
  [ At, Colon, DotDot, DoubleColon, Equals, Backslash, Bar
  , LeftArrow, RightArrow, Tilde, Bind, Select ]

commentCategories :: [Category]
commentCategories = [LineComment, NestedComment]

identCategories :: [Category]
identCategories = [Id, QId, Sym, QSym, SymDot, SymMinus, SymMinusDot]

isPragmaToken :: Token -> Bool
isPragmaToken (Token cat _) = cat `elem` pragmaCategories

isPragmaEnd :: Token -> Bool
isPragmaEnd (Token cat _) = cat == PragmaEnd
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
202
203

isTokenIdentifier :: Token -> Bool
204
205
206
207
208
209
210
isTokenIdentifier (Token cat _) = cat `elem` identCategories

whiteSpaceCategories :: [Category]
whiteSpaceCategories = [EOF, VSemicolon, VRightBrace]

pragmaCategories :: [Category]
pragmaCategories = [PragmaLanguage, PragmaOptions, PragmaEnd]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
211
212
213

-- DECL Position

214
215
216
217
218
219
220
declPos :: Decl -> Position
declPos (InfixDecl        p _ _ _  ) = p
declPos (DataDecl         p _ _ _  ) = p
declPos (NewtypeDecl      p _ _ _  ) = p
declPos (TypeDecl         p _ _ _  ) = p
declPos (TypeSig          p _ _    ) = p
declPos (FunctionDecl     p _ _    ) = p
221
222
declPos (ForeignDecl      p _ _ _ _) = p
declPos (ExternalDecl     p _      ) = p
223
declPos (PatternDecl      p _ _    ) = p
224
declPos (FreeDecl         p _      ) = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
225

226
227
cmpDecl :: Decl -> Decl -> Ordering
cmpDecl = compare `on` declPos
228

229
230
cmpImportDecl :: ImportDecl -> ImportDecl -> Ordering
cmpImportDecl = compare `on` (\ (ImportDecl p _ _ _ _) -> p)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
231

232
233
-- -----------------------------------------------------------------------------
-- Extract all identifiers mentioned in the source code as a Code entity
234
235
236
-- in the order of their occurrence. The extracted information is then used
-- to enrich the identifier tokens with additional information, e.g., for
-- link generation.
237
-- -----------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
238

239
240
241
idsModule :: Module -> [Code]
idsModule (Module _ mid es is ds) =
  let hdrCodes = ModuleName mid : idsExportSpec es
242
243
      impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is)
      dclCodes = concatMap idsDecl       (sortBy cmpDecl ds)
244
  in  map (addModuleIdent mid) $ hdrCodes ++ impCodes ++ dclCodes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
addModuleIdent :: ModuleIdent -> Code -> Code
addModuleIdent mid c@(Function x qid)
  | hasGlobalScope (unqualify qid) = Function x (qualQualify mid qid)
  | otherwise                      = c
addModuleIdent mid cn@(DataCons x qid)
  | not $ isQualified qid          = DataCons x (qualQualify mid qid)
  | otherwise                      = cn
addModuleIdent mid tc@(TypeCons x qid)
  | not $ isQualified qid          = TypeCons x (qualQualify mid qid)
  | otherwise                      = tc
addModuleIdent mid lb@(Label x qid)
  | not $ isQualified qid          = Label    x (qualQualify mid qid)
  | otherwise                      = lb
addModuleIdent _   c               = c

-- Exports

idsExportSpec ::  Maybe ExportSpec -> [Code]
idsExportSpec Nothing                 = []
idsExportSpec (Just (Exporting _ es)) = concatMap idsExport es

idsExport :: Export -> [Code]
idsExport (Export            qid) = [Function FuncExport qid]
idsExport (ExportTypeWith qid cs) = TypeCons TypeExport qid :
  map (DataCons ConsExport . qualify) cs
idsExport (ExportTypeAll     qid) = [TypeCons TypeExport qid]
idsExport (ExportModule      mid) = [ModuleName mid]

-- Imports

idsImportDecl :: ImportDecl -> [Code]
idsImportDecl (ImportDecl _ mid _ mAlias spec)
  = ModuleName mid : aliasCode ++ maybe [] (idsImportSpec mid) spec
  where aliasCode = maybe [] ((:[]) . ModuleName) mAlias

idsImportSpec :: ModuleIdent -> ImportSpec -> [Code]
idsImportSpec mid (Importing _ is) = concatMap (idsImport mid) is
idsImportSpec mid (Hiding    _ is) = concatMap (idsImport mid) is

idsImport :: ModuleIdent -> Import -> [Code]
idsImport mid (Import            i) =
  [Function FuncImport $ qualifyWith mid i]
idsImport mid (ImportTypeWith t cs) =
  TypeCons TypeImport (qualifyWith mid t) :
    map (DataCons ConsImport . qualifyWith mid) cs
idsImport mid (ImportTypeAll     t) =
  [TypeCons TypeImport $ qualifyWith mid t]

-- Declarations

idsDecl :: Decl -> [Code]
idsDecl (InfixDecl _   _ _ ops) = map (Function FuncInfix . qualify) ops
idsDecl (DataDecl   _ d vs cds) = TypeCons TypeDeclare (qualify d)
                                    :  map (Identifier IdDeclare . qualify) vs
                                    ++ concatMap idsConstrDecl cds
idsDecl (NewtypeDecl   _ _ _ _) = []
idsDecl (TypeDecl    _ t vs ty) = TypeCons TypeDeclare (qualify t)
                                    :  map (Identifier IdDeclare . qualify) vs
                                    ++ idsTypeExpr ty
idsDecl (TypeSig       _ fs ty) = map (Function FuncTypeSig . qualify) fs
                                    ++ idsTypeExpr ty
idsDecl (FunctionDecl  _ _ eqs) = concatMap idsEquation eqs
idsDecl (ForeignDecl _ _ _ _ _) = []
idsDecl (ExternalDecl     _ fs) = map (Function FuncDeclare . qualify) fs
idsDecl (PatternDecl   _ p rhs) = idsPat p ++ idsRhs rhs
idsDecl (FreeDecl         _ vs) = map (Identifier IdDeclare . qualify) vs

idsConstrDecl :: ConstrDecl -> [Code]
idsConstrDecl (ConstrDecl     _ _ c tys)
  = DataCons ConsDeclare (qualify c) : concatMap idsTypeExpr tys
idsConstrDecl (ConOpDecl _ _ ty1 op ty2)
  = idsTypeExpr ty1 ++ (DataCons ConsDeclare $ qualify op) : idsTypeExpr ty2

idsTypeExpr :: TypeExpr -> [Code]
idsTypeExpr (ConstructorType qid tys) = TypeCons TypeRefer qid :
                                           concatMap idsTypeExpr tys
idsTypeExpr (VariableType          v) = [Identifier IdRefer (qualify v)]
idsTypeExpr (TupleType           tys) = concatMap idsTypeExpr tys
idsTypeExpr (ListType             ty) = idsTypeExpr ty
idsTypeExpr (ArrowType       ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]
326
idsTypeExpr (RecordType           fs) = concatMap idsFieldType fs
327
328

idsFieldType :: ([Ident], TypeExpr) -> [Code]
329
330
idsFieldType (fs, ty) = map (Label LabelDeclare . qualify . unRenameIdent) fs
                          ++ idsTypeExpr ty
331
332
333
334
335
336

idsEquation :: Equation -> [Code]
idsEquation (Equation _ lhs rhs) = idsLhs lhs ++ idsRhs rhs

idsLhs :: Lhs -> [Code]
idsLhs (FunLhs    f ps) = Function FuncDeclare (qualify f) : concatMap idsPat ps
337
338
idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare $ qualify op]
                                    ++ idsPat p2
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
idsLhs (ApLhs   lhs ps) = idsLhs lhs ++ concatMap idsPat ps

idsRhs :: Rhs -> [Code]
idsRhs (SimpleRhs _ e ds) = idsExpr e ++ concatMap idsDecl ds
idsRhs (GuardedRhs ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds

idsCondExpr :: CondExpr -> [Code]
idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2

idsPat :: Pattern -> [Code]
idsPat (LiteralPattern          _) = []
idsPat (NegativePattern       _ _) = []
idsPat (VariablePattern         v) = [Identifier IdDeclare (qualify v)]
idsPat (ConstructorPattern qid ps) = DataCons ConsPattern qid
                                      : concatMap idsPat ps
354
355
idsPat (InfixPattern    p1 qid p2) = idsPat p1 ++
                                       DataCons ConsPattern qid : idsPat p2
356
357
358
359
360
361
362
idsPat (ParenPattern            p) = idsPat p
idsPat (TuplePattern         _ ps) = concatMap idsPat ps
idsPat (ListPattern          _ ps) = concatMap idsPat ps
idsPat (AsPattern             v p) = Identifier IdDeclare (qualify v) : idsPat p
idsPat (LazyPattern           _ p) = idsPat p
idsPat (FunctionPattern    qid ps) = Function FuncCall qid
                                      : concatMap idsPat ps
363
364
365
idsPat (InfixFuncPattern  p1 f p2) = idsPat p1 ++
                                      Function FuncInfix f : idsPat p2
idsPat (RecordPattern        fs _) = concatMap (idsField idsPat) fs
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392

idsExpr :: Expression -> [Code]
idsExpr (Literal                _) = []
idsExpr (Variable             qid)
  | isQualified qid                = [Function FuncCall qid]
  | hasGlobalScope (unqualify qid) = [Function FuncCall qid]
  | otherwise                      = [Identifier IdRefer qid]
idsExpr (Constructor          qid) = [DataCons ConsCall qid]
idsExpr (Paren                  e) = idsExpr e
idsExpr (Typed               e ty) = idsExpr e ++ idsTypeExpr ty
idsExpr (Tuple               _ es) = concatMap idsExpr es
idsExpr (List                _ es) = concatMap idsExpr es
idsExpr (ListCompr      _ e stmts) = idsExpr e ++ concatMap idsStmt stmts
idsExpr (EnumFrom               e) = idsExpr e
idsExpr (EnumFromThen       e1 e2) = concatMap idsExpr [e1, e2]
idsExpr (EnumFromTo         e1 e2) = concatMap idsExpr [e1, e2]
idsExpr (EnumFromThenTo  e1 e2 e3) = concatMap idsExpr [e1, e2, e3]
idsExpr (UnaryMinus       ident e) = Symbol (idName ident) : idsExpr e
idsExpr (Apply              e1 e2) = idsExpr e1 ++ idsExpr e2
idsExpr (InfixApply      e1 op e2) = idsExpr e1 ++ idsInfix op ++ idsExpr e2
idsExpr (LeftSection         e op) = idsExpr e ++ idsInfix op
idsExpr (RightSection        op e) = idsInfix op ++ idsExpr e
idsExpr (Lambda            _ ps e) = concatMap idsPat ps ++ idsExpr e
idsExpr (Let                 ds e) = concatMap idsDecl ds ++ idsExpr e
idsExpr (Do               stmts e) = concatMap idsStmt stmts ++ idsExpr e
idsExpr (IfThenElse    _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]
idsExpr (Case          _ _ e alts) = idsExpr e ++ concatMap idsAlt alts
393
394
395
396
397
398
399
400
idsExpr (RecordConstr          fs) = concatMap (idsField idsExpr) fs
idsExpr (RecordSelection      e l)
  = idsExpr e ++ [Label LabelRefer (qualify $ unRenameIdent l)]
idsExpr (RecordUpdate        fs e) = concatMap (idsField idsExpr) fs
                                     ++ idsExpr e

idsField :: (a -> [Code]) -> Field a -> [Code]
idsField f (Field _ l x) = Label LabelRefer (qualify $ unRenameIdent l) : f x
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437

idsInfix :: InfixOp -> [Code]
idsInfix (InfixOp     qid) = [Function FuncInfix qid]
idsInfix (InfixConstr qid) = [DataCons ConsInfix qid]

idsStmt :: Statement -> [Code]
idsStmt (StmtExpr   _ e) = idsExpr e
idsStmt (StmtDecl    ds) = concatMap idsDecl ds
idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e

idsAlt :: Alt -> [Code]
idsAlt (Alt _ p rhs) = idsPat p ++ idsRhs rhs

-- -----------------------------------------------------------------------------
-- Conversion from a token to a string
-- -----------------------------------------------------------------------------

showToken :: Token -> String
showToken (Token Id                 a) = showAttr a
showToken (Token QId                a) = showAttr a
showToken (Token Sym                a) = showAttr a
showToken (Token QSym               a) = showAttr a
showToken (Token IntTok             a) = showAttr a
showToken (Token FloatTok           a) = showAttr a
showToken (Token CharTok            a) = showAttr a
showToken (Token StringTok          a) = showAttr a
showToken (Token LeftParen          _) = "("
showToken (Token RightParen         _) = ")"
showToken (Token Semicolon          _) = ";"
showToken (Token LeftBrace          _) = "{"
showToken (Token RightBrace         _) = "}"
showToken (Token LeftBracket        _) = "["
showToken (Token RightBracket       _) = "]"
showToken (Token Comma              _) = ","
showToken (Token Underscore         _) = "_"
showToken (Token Backquote          _) = "`"
showToken (Token VSemicolon         _) = ""
438
showToken (Token LeftBraceSemicolon _) = "{;"
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
showToken (Token VRightBrace        _) = ""
showToken (Token At                 _) = "@"
showToken (Token Colon              _) = ":"
showToken (Token DotDot             _) = ".."
showToken (Token DoubleColon        _) = "::"
showToken (Token Equals             _) = "="
showToken (Token Backslash          _) = "\\"
showToken (Token Bar                _) = "|"
showToken (Token LeftArrow          _) = "<-"
showToken (Token RightArrow         _) = "->"
showToken (Token Tilde              _) = "~"
showToken (Token Bind               _) = ":="
showToken (Token Select             _) = ":>"
showToken (Token SymDot             _) = "."
showToken (Token SymMinus           _) = "-"
showToken (Token SymMinusDot        _) = "-."
showToken (Token KW_case            _) = "case"
showToken (Token KW_data            _) = "data"
showToken (Token KW_do              _) = "do"
showToken (Token KW_else            _) = "else"
showToken (Token KW_external        _) = "external"
showToken (Token KW_fcase           _) = "fcase"
showToken (Token KW_foreign         _) = "foreign"
showToken (Token KW_free            _) = "free"
showToken (Token KW_if              _) = "if"
showToken (Token KW_import          _) = "import"
showToken (Token KW_in              _) = "in"
showToken (Token KW_infix           _) = "infix"
showToken (Token KW_infixl          _) = "infixl"
showToken (Token KW_infixr          _) = "infixr"
showToken (Token KW_let             _) = "let"
showToken (Token KW_module          _) = "module"
showToken (Token KW_newtype         _) = "newtype"
showToken (Token KW_of              _) = "of"
showToken (Token KW_then            _) = "then"
showToken (Token KW_type            _) = "type"
showToken (Token KW_where           _) = "where"
showToken (Token Id_as              _) = "as"
showToken (Token Id_ccall           _) = "ccall"
showToken (Token Id_forall          _) = "forall"
showToken (Token Id_hiding          _) = "hiding"
showToken (Token Id_interface       _) = "interface"
showToken (Token Id_primitive       _) = "primitive"
showToken (Token Id_qualified       _) = "qualified"
showToken (Token EOF                _) = ""
showToken (Token PragmaLanguage     _) = "{-# LANGUAGE"
showToken (Token PragmaOptions      a) = "{-# OPTIONS" ++ showAttr a
showToken (Token PragmaEnd          _) = "#-}"
showToken (Token LineComment   (StringAttributes s _)) = s
showToken (Token LineComment   a                     ) = showAttr a
showToken (Token NestedComment (StringAttributes s _)) = s
showToken (Token NestedComment                      a) = showAttr a
491
492

showAttr :: Attributes -> [Char]
493
showAttr NoAttributes             = ""
494
495
496
497
498
499
500
showAttr (CharAttributes     c _) = show c
showAttr (IntAttributes      i _) = show i
showAttr (FloatAttributes    f _) = show f
showAttr (StringAttributes   s _) = show s
showAttr (IdentAttributes    m i)
  | null m    = show $ qualify                  (mkIdent i)
  | otherwise = show $ qualifyWith (mkMIdent m) (mkIdent i)
501
502
503
504
505
showAttr (OptionsAttributes mt s) = showTool mt ++ ' ' : s

showTool :: Maybe String -> String
showTool Nothing  = ""
showTool (Just t) = '_' : t