SyntaxColoring.hs 20.1 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 (..)
Björn Peemöller 's avatar
Björn Peemöller committed
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
  | Pragma      String
  | TypeCons    TypeUsage  QualIdent
  | DataCons    ConsUsage  QualIdent
  | Function    FuncUsage  QualIdent
  | Identifier  IdentUsage QualIdent
  | ModuleName  ModuleIdent
  | Commentary  String
  | NumberCode  String
  | StringCode  String
  | CharCode    String
  | Symbol      String
48 49
    deriving Show

50 51 52
data TypeUsage
  = TypeDeclare
  | TypeRefer
Björn Peemöller 's avatar
Björn Peemöller committed
53
  | TypeExport
54
  | TypeImport
Björn Peemöller 's avatar
Björn Peemöller committed
55
    deriving Show
56

57 58 59 60 61 62 63
data ConsUsage
  = ConsDeclare
  | ConsPattern
  | ConsCall
  | ConsInfix
  | ConsExport
  | ConsImport
Björn Peemöller 's avatar
Björn Peemöller committed
64
    deriving Show
65

66 67 68 69 70 71 72
data FuncUsage
  = FuncDeclare
  | FuncTypeSig
  | FuncCall
  | FuncInfix
  | FuncExport
  | FuncImport
Björn Peemöller 's avatar
Björn Peemöller committed
73
    deriving Show
74

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

81 82 83 84
-- @param list with parse-Results with descending quality,
--        e.g. [typingParse, fullParse, parse]
-- @param lex-Result
-- @return program
85 86
genProgram :: String -> Module -> [(Position, Token)] -> [Code]
genProgram fn m toks = tokenToCodes (first fn) (idsModule m) toks
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
87

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
-- @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
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
108 109
        str = intercalate " " $ map (showToken . snd) (pragmas ++ [end])
    in  Pragma str : tokenToCodes (incr curPos (length str)) ids rest
110 111 112 113 114 115 116 117 118 119 120 121 122 123
  -- 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
124 125

code2string :: Code -> String
126
code2string (Keyword         s) = s
127
code2string (Space           i) = replicate i ' '
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
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 (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)
155 156
  | otherwise                         = internalError $
    "SyntaxColoring.tokenToCode: Unknown token" ++ showToken tok
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

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
194 195

isTokenIdentifier :: Token -> Bool
196 197 198 199 200 201 202
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
203 204 205

-- DECL Position

206 207 208 209 210 211 212
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
213 214
declPos (ForeignDecl      p _ _ _ _) = p
declPos (ExternalDecl     p _      ) = p
215
declPos (PatternDecl      p _ _    ) = p
216
declPos (FreeDecl         p _      ) = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
217

218 219
cmpDecl :: Decl -> Decl -> Ordering
cmpDecl = compare `on` declPos
220

221 222
cmpImportDecl :: ImportDecl -> ImportDecl -> Ordering
cmpImportDecl = compare `on` (\ (ImportDecl p _ _ _ _) -> p)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
223

224 225
-- -----------------------------------------------------------------------------
-- Extract all identifiers mentioned in the source code as a Code entity
226 227 228
-- 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.
229
-- -----------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
230

231 232 233
idsModule :: Module -> [Code]
idsModule (Module _ mid es is ds) =
  let hdrCodes = ModuleName mid : idsExportSpec es
234 235
      impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is)
      dclCodes = concatMap idsDecl       (sortBy cmpDecl ds)
236
  in  map (addModuleIdent mid) $ hdrCodes ++ impCodes ++ dclCodes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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 284 285 286 287 288 289
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 _   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
290 291 292
idsDecl (NewtypeDecl _ t vs nc) = TypeCons TypeDeclare (qualify t)
                                    :  map (Identifier IdDeclare . qualify) vs
                                    ++ idsNewConstrDecl nc
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308
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
309 310 311 312 313 314 315 316 317
idsConstrDecl (RecordDecl _ _ c fs)
  = DataCons ConsDeclare (qualify c) : concatMap idsFieldDecl fs

idsNewConstrDecl :: NewConstrDecl -> [Code]
idsNewConstrDecl (NewConstrDecl _ _ c ty)
  = DataCons ConsDeclare (qualify c) : idsTypeExpr ty
idsNewConstrDecl (NewRecordDecl _ _ c (l,ty))
  = DataCons ConsDeclare (qualify c) : (Function FuncDeclare $ qualify l)
  : idsTypeExpr ty
318 319 320 321 322 323 324 325

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 (ParenType            ty) = idsTypeExpr ty
327

328 329 330
idsFieldDecl :: FieldDecl -> [Code]
idsFieldDecl (FieldDecl _ ls ty) =
  map (Function FuncDeclare . qualify . unRenameIdent) ls ++ 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
idsPat (ParenPattern            p) = idsPat p
357 358
idsPat (RecordPattern      qid fs) = DataCons ConsPattern qid
                                      : concatMap (idsField idsPat) fs
359 360 361 362 363 364
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
365 366
idsPat (InfixFuncPattern  p1 f p2) = idsPat p1 ++
                                      Function FuncInfix f : idsPat p2
367 368 369 370 371 372 373 374 375 376

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
377 378 379 380
idsExpr (Record            qid fs) = DataCons ConsCall qid
                                      : concatMap (idsField idsExpr) fs
idsExpr (RecordUpdate        e fs) = idsExpr e
                                      ++ concatMap (idsField idsExpr) fs
381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397
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
398 399

idsField :: (a -> [Code]) -> Field a -> [Code]
400
idsField f (Field _ l x) = Function FuncCall 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         _) = ""
Björn Peemöller 's avatar
Björn Peemöller committed
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
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                _) = ""
484
showToken (Token PragmaHiding       _) = "{-# HIDING"
485 486 487 488 489 490 491
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
Björn Peemöller 's avatar
Björn Peemöller committed
492 493

showAttr :: Attributes -> [Char]
494
showAttr NoAttributes             = ""
495 496 497 498 499 500 501
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)
502 503 504 505 506
showAttr (OptionsAttributes mt s) = showTool mt ++ ' ' : s

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