{-# LANGUAGE CPP #-}
module X86.RegInfo (
        mkVirtualReg,
        regDotColor
)

where

#include "nativeGen/NCG.h"
#include "HsVersions.h"

import GhcPrelude

import Format
import Reg

import Outputable
import Platform
import Unique

import UniqFM
import X86.Regs

mkVirtualReg :: Unique -> Format -> VirtualReg
mkVirtualReg u format
   = case format of
        FF32    -> VirtualRegSSE u
        FF64    -> VirtualRegSSE u
        FF80    -> VirtualRegD   u
        _other  -> VirtualRegI   u

regDotColor :: Platform -> RealReg -> SDoc
regDotColor platform reg
 = case (lookupUFM (regColors platform) reg) of
        Just str -> text str
        _        -> panic "Register not assigned a color"

regColors :: Platform -> UniqFM [Char]
regColors platform = listToUFM (normalRegColors platform ++ fpRegColors platform)

normalRegColors :: Platform -> [(Reg,String)]
normalRegColors platform =
    zip (map regSingle [0..lastint platform]) colors
  where
    -- 16 colors - enough for amd64 gp regs
    colors = ["#800000","#ff0000","#808000","#ffff00","#008000"
             ,"#00ff00","#008080","#00ffff","#000080","#0000ff"
             ,"#800080","#ff00ff","#87005f","#875f00","#87af00"
             ,"#ff00af"]

fpRegColors :: Platform -> [(Reg,String)]
fpRegColors platform =
        [ (fake0, "red")
        , (fake1, "red")
        , (fake2, "red")
        , (fake3, "red")
        , (fake4, "red")
        , (fake5, "red") ]

        ++ zip (map regSingle [firstxmm..lastxmm platform]) greys
  where
    -- 16 shades of grey, enough for the currently supported
    -- SSE extensions.
    greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646"
            ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c"
            ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2"
            ,"#e0e0e0"]

--     32 shades of grey - use for avx 512 if we ever need it
--     greys = ["#070707","#0e0e0e","#151515","#1c1c1c"
--             ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f"
--             ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262"
--             ,"#696969","#707070","#777777","#7e7e7e","#858585"
--             ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8"
--             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb"
--             ,"#d2d2d2","#d9d9d9","#e0e0e0"]


{-# LANGUAGE CPP #-}

module X86.Regs (
        -- squeese functions for the graph allocator
        virtualRegSqueeze,
        realRegSqueeze,

        -- immediates
        Imm(..),
        strImmLit,
        litToImm,

        -- addressing modes
        AddrMode(..),
        addrOffset,

        -- registers
        spRel,
        argRegs,
        allArgRegs,
        allIntArgRegs,
        callClobberedRegs,
        instrClobberedRegs,
        allMachRegNos,
        classOfRealReg,
        showReg,

        -- machine specific
        EABase(..), EAIndex(..), addrModeRegs,

        eax, ebx, ecx, edx, esi, edi, ebp, esp,
        fake0, fake1, fake2, fake3, fake4, fake5, firstfake,

        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,
        r8,  r9,  r10, r11, r12, r13, r14, r15,
        lastint,
        xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
        xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,
        xmm,
        firstxmm, lastxmm,

        ripRel,
        allFPArgRegs,

        allocatableRegs
)

where

#include "nativeGen/NCG.h"
#include "HsVersions.h"

import GhcPrelude

import CodeGen.Platform
import Reg
import RegClass

import Cmm
import CLabel           ( CLabel )
import DynFlags
import Outputable
import Platform

import qualified Data.Array as A

-- | regSqueeze_class reg
--      Calculate the maximum number of register colors that could be
--      denied to a node of this class due to having this reg
--      as a neighbour.
--
{-# INLINE virtualRegSqueeze #-}
virtualRegSqueeze :: RegClass -> VirtualReg -> Int

virtualRegSqueeze cls vr
 = case cls of
        RcInteger
         -> case vr of
                VirtualRegI{}           -> 1
                VirtualRegHi{}          -> 1
                _other                  -> 0

        RcDouble
         -> case vr of
                VirtualRegD{}           -> 1
                VirtualRegF{}           -> 0
                _other                  -> 0

        RcDoubleSSE
         -> case vr of
                VirtualRegSSE{}         -> 1
                _other                  -> 0

        _other -> 0

{-# INLINE realRegSqueeze #-}
realRegSqueeze :: RegClass -> RealReg -> Int
realRegSqueeze cls rr
 = case cls of
        RcInteger
         -> case rr of
                RealRegSingle regNo
                        | regNo < firstfake -> 1
                        | otherwise     -> 0

                RealRegPair{}           -> 0

        RcDouble
         -> case rr of
                RealRegSingle regNo
                        | regNo >= firstfake && regNo <= lastfake -> 1
                        | otherwise     -> 0

                RealRegPair{}           -> 0

        RcDoubleSSE
         -> case rr of
                RealRegSingle regNo | regNo >= firstxmm -> 1
                _otherwise                        -> 0

        _other -> 0

-- -----------------------------------------------------------------------------
-- Immediates

data Imm
  = ImmInt      Int
  | ImmInteger  Integer     -- Sigh.
  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)
  | ImmLit      SDoc        -- Simple string
  | ImmIndex    CLabel Int
  | ImmFloat    Rational
  | ImmDouble   Rational
  | ImmConstantSum Imm Imm
  | ImmConstantDiff Imm Imm

strImmLit :: String -> Imm
strImmLit s = ImmLit (text s)

litToImm :: CmmLit -> Imm
litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
                -- narrow to the width: a CmmInt might be out of
                -- range, but we assume that ImmInteger only contains
                -- in-range values.  A signed value should be fine here.
litToImm (CmmFloat f W32)    = ImmFloat f
litToImm (CmmFloat f W64)    = ImmDouble f
litToImm (CmmLabel l)        = ImmCLbl l
litToImm (CmmLabelOff l off) = ImmIndex l off
litToImm (CmmLabelDiffOff l1 l2 off _)
                             = ImmConstantSum
                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
                               (ImmInt off)
litToImm _                   = panic "X86.Regs.litToImm: no match"

-- addressing modes ------------------------------------------------------------

data AddrMode
        = AddrBaseIndex EABase EAIndex Displacement
        | ImmAddr Imm Int

data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip
data EAIndex      = EAIndexNone | EAIndex Reg Int
type Displacement = Imm

addrOffset :: AddrMode -> Int -> Maybe AddrMode
addrOffset addr off
  = case addr of
      ImmAddr i off0      -> Just (ImmAddr i (off0 + off))

      AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))
      AddrBaseIndex r i (ImmInteger n)
        -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))

      AddrBaseIndex r i (ImmCLbl lbl)
        -> Just (AddrBaseIndex r i (ImmIndex lbl off))

      AddrBaseIndex r i (ImmIndex lbl ix)
        -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))

      _ -> Nothing  -- in theory, shouldn't happen

addrModeRegs :: AddrMode -> [Reg]
addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs
  where
   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }
   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }
addrModeRegs _ = []

-- registers -------------------------------------------------------------------

-- @spRel@ gives us a stack relative addressing mode for volatile
-- temporaries and for excess call arguments.  @fpRel@, where
-- applicable, is the same but for the frame pointer.

spRel :: DynFlags
      -> Int -- ^ desired stack offset in bytes, positive or negative
      -> AddrMode
spRel dflags n
 | target32Bit (targetPlatform dflags)
    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)
 | otherwise
    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)

-- The register numbers must fit into 32 bits on x86, so that we can
-- use a Word32 to represent the set of free registers in the register
-- allocator.

firstfake, lastfake :: RegNo
firstfake = 16
lastfake  = 21

firstxmm :: RegNo
firstxmm  = 24

lastxmm :: Platform -> RegNo
lastxmm platform
 | target32Bit platform = 31
 | otherwise            = 39

lastint :: Platform -> RegNo
lastint platform
 | target32Bit platform = 7 -- not %r8..%r15
 | otherwise            = 15

intregnos :: Platform -> [RegNo]
intregnos platform = [0 .. lastint platform]

fakeregnos :: [RegNo]
fakeregnos  = [firstfake .. lastfake]

xmmregnos :: Platform -> [RegNo]
xmmregnos platform = [firstxmm  .. lastxmm platform]

floatregnos :: Platform -> [RegNo]
floatregnos platform = fakeregnos ++ xmmregnos platform

-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
argRegs :: RegNo -> [Reg]
argRegs _       = panic "MachRegs.argRegs(x86): should not be used!"

-- | The complete set of machine registers.
allMachRegNos :: Platform -> [RegNo]
allMachRegNos platform = intregnos platform ++ floatregnos platform

-- | Take the class of a register.
{-# INLINE classOfRealReg #-}
classOfRealReg :: Platform -> RealReg -> RegClass
-- On x86, we might want to have an 8-bit RegClass, which would
-- contain just regs 1-4 (the others don't have 8-bit versions).
-- However, we can get away without this at the moment because the
-- only allocatable integer regs are also 8-bit compatible (1, 3, 4).
classOfRealReg platform reg
 = case reg of
        RealRegSingle i
          | i <= lastint platform -> RcInteger
          | i <= lastfake         -> RcDouble
          | otherwise             -> RcDoubleSSE

        RealRegPair{}   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"

-- | Get the name of the register with this number.
showReg :: Platform -> RegNo -> String
showReg platform n
        | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)
        | n >= firstfake = "%fake" ++ show (n-firstfake)
        | n >= 8         = "%r" ++ show n
        | otherwise      = regNames platform A.! n

regNames :: Platform -> A.Array Int String
regNames platform
    = if target32Bit platform
      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]

-- machine specific ------------------------------------------------------------

{-
Intel x86 architecture:
- All registers except 7 (esp) are available for use.
- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable
  fp registers, and 3-operand insns for them, and we translate this into
  real stack-based x86 fp code after register allocation.

The fp registers are all Double registers; we don't have any RcFloat class
regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should
never generate them.
-}

fake0, fake1, fake2, fake3, fake4, fake5,
       eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg

eax   = regSingle 0
ebx   = regSingle 1
ecx   = regSingle 2
edx   = regSingle 3
esi   = regSingle 4
edi   = regSingle 5
ebp   = regSingle 6
esp   = regSingle 7
fake0 = regSingle 16
fake1 = regSingle 17
fake2 = regSingle 18
fake3 = regSingle 19
fake4 = regSingle 20
fake5 = regSingle 21

{-
AMD x86_64 architecture:
- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:

  8     16    32    64
  ---------------------
  al    ax    eax   rax
  bl    bx    ebx   rbx
  cl    cx    ecx   rcx
  dl    dx    edx   rdx
  sil   si    esi   rsi
  dil   si    edi   rdi
  bpl   bp    ebp   rbp
  spl   sp    esp   rsp
  r10b  r10w  r10d  r10
  r11b  r11w  r11d  r11
  r12b  r12w  r12d  r12
  r13b  r13w  r13d  r13
  r14b  r14w  r14d  r14
  r15b  r15w  r15d  r15
-}

rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
  r8, r9, r10, r11, r12, r13, r14, r15,
  xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
  xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg

rax   = regSingle 0
rbx   = regSingle 1
rcx   = regSingle 2
rdx   = regSingle 3
rsi   = regSingle 4
rdi   = regSingle 5
rbp   = regSingle 6
rsp   = regSingle 7
r8    = regSingle 8
r9    = regSingle 9
r10   = regSingle 10
r11   = regSingle 11
r12   = regSingle 12
r13   = regSingle 13
r14   = regSingle 14
r15   = regSingle 15
xmm0  = regSingle 24
xmm1  = regSingle 25
xmm2  = regSingle 26
xmm3  = regSingle 27
xmm4  = regSingle 28
xmm5  = regSingle 29
xmm6  = regSingle 30
xmm7  = regSingle 31
xmm8  = regSingle 32
xmm9  = regSingle 33
xmm10 = regSingle 34
xmm11 = regSingle 35
xmm12 = regSingle 36
xmm13 = regSingle 37
xmm14 = regSingle 38
xmm15 = regSingle 39

ripRel :: Displacement -> AddrMode
ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm

 -- so we can re-use some x86 code:
{-
eax = rax
ebx = rbx
ecx = rcx
edx = rdx
esi = rsi
edi = rdi
ebp = rbp
esp = rsp
-}

xmm :: RegNo -> Reg
xmm n = regSingle (firstxmm+n)

-- | these are the regs which we cannot assume stay alive over a C call.
callClobberedRegs       :: Platform -> [Reg]
-- caller-saves registers
callClobberedRegs platform
 | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
 | platformOS platform == OSMinGW32
   = [rax,rcx,rdx,r8,r9,r10,r11]
   -- Only xmm0-5 are caller-saves registers on 64bit windows.
   -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )
   -- For details check the Win64 ABI.
   ++ map regSingle fakeregnos ++ map xmm [0  .. 5]
 | otherwise
    -- all xmm regs are caller-saves
    -- caller-saves registers
    = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11]
   ++ map regSingle (floatregnos platform)

allArgRegs :: Platform -> [(Reg, Reg)]
allArgRegs platform
 | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9]
                                          (map regSingle [firstxmm ..])
 | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch"

allIntArgRegs :: Platform -> [Reg]
allIntArgRegs platform
 | (platformOS platform == OSMinGW32) || target32Bit platform
    = panic "X86.Regs.allIntArgRegs: not defined for this platform"
 | otherwise = [rdi,rsi,rdx,rcx,r8,r9]

allFPArgRegs :: Platform -> [Reg]
allFPArgRegs platform
 | platformOS platform == OSMinGW32
    = panic "X86.Regs.allFPArgRegs: not defined for this platform"
 | otherwise = map regSingle [firstxmm .. firstxmm+7]

-- Machine registers which might be clobbered by instructions that
-- generate results into fixed registers, or need arguments in a fixed
-- register.
instrClobberedRegs :: Platform -> [Reg]
instrClobberedRegs platform
 | target32Bit platform = [ eax, ecx, edx ]
 | otherwise            = [ rax, rcx, rdx ]

--

-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
-- i.e., these are the regs for which we are prepared to allow the
-- register allocator to attempt to map VRegs to.
allocatableRegs :: Platform -> [RealReg]
allocatableRegs platform
   = let isFree i = freeReg platform i
     in  map RealRegSingle $ filter isFree (allMachRegNos platform)


{-# LANGUAGE DeriveDataTypeable #-}

module ApiAnnotation (
  getAnnotation, getAndRemoveAnnotation,
  getAnnotationComments,getAndRemoveAnnotationComments,
  ApiAnns,
  ApiAnnKey,
  AnnKeywordId(..),
  AnnotationComment(..),
  IsUnicodeSyntax(..),
  unicodeAnn,
  HasE(..),
  LRdrName -- Exists for haddocks only
  ) where

import GhcPrelude

import RdrName
import Outputable
import SrcLoc
import qualified Data.Map as Map
import Data.Data

{-
Note [Api annotations]
~~~~~~~~~~~~~~~~~~~~~~
Given a parse tree of a Haskell module, how can we reconstruct
the original Haskell source code, retaining all whitespace and
source code comments?  We need to track the locations of all
elements from the original source: this includes keywords such as
'let' / 'in' / 'do' etc as well as punctuation such as commas and
braces, and also comments.  We collectively refer to this
metadata as the "API annotations".

Rather than annotate the resulting parse tree with these locations
directly (this would be a major change to some fairly core data
structures in GHC), we instead capture locations for these elements in a
structure separate from the parse tree, and returned in the
pm_annotations field of the ParsedModule type.

The full ApiAnns type is

> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]                  -- non-comments
>                , Map.Map SrcSpan [Located AnnotationComment]) -- comments

NON-COMMENT ELEMENTS

Intuitively, every AST element directly contains a bag of keywords
(keywords can show up more than once in a node: a semicolon i.e. newline
can show up multiple times before the next AST element), each of which
needs to be associated with its location in the original source code.

Consequently, the structure that records non-comment elements is logically
a two level map, from the SrcSpan of the AST element containing it, to
a map from keywords ('AnnKeyWord') to all locations of the keyword directly
in the AST element:

> type ApiAnnKey = (SrcSpan,AnnKeywordId)
>
> Map.Map ApiAnnKey [SrcSpan]

So

> let x = 1 in 2 *x

would result in the AST element

  L span (HsLet (binds for x = 1) (2 * x))

and the annotations

  (span,AnnLet) having the location of the 'let' keyword
  (span,AnnEqual) having the location of the '=' sign
  (span,AnnIn)  having the location of the 'in' keyword

For any given element in the AST, there is only a set number of
keywords that are applicable for it (e.g., you'll never see an
'import' keyword associated with a let-binding.)  The set of allowed
keywords is documented in a comment associated with the constructor
of a given AST element, although the ground truth is in Parser
and RdrHsSyn (which actually add the annotations; see #13012).

COMMENT ELEMENTS

Every comment is associated with a *located* AnnotationComment.
We associate comments with the lowest (most specific) AST element
enclosing them:

> Map.Map SrcSpan [Located AnnotationComment]

PARSER STATE

There are three fields in PState (the parser state) which play a role
with annotations.

>  annotations :: [(ApiAnnKey,[SrcSpan])],
>  comment_q :: [Located AnnotationComment],
>  annotations_comments :: [(SrcSpan,[Located AnnotationComment])]

The 'annotations' and 'annotations_comments' fields are simple: they simply
accumulate annotations that will end up in 'ApiAnns' at the end
(after they are passed to Map.fromList).

The 'comment_q' field captures comments as they are seen in the token stream,
so that when they are ready to be allocated via the parser they are
available (at the time we lex a comment, we don't know what the enclosing
AST node of it is, so we can't associate it with a SrcSpan in
annotations_comments).

PARSER EMISSION OF ANNOTATIONS

The parser interacts with the lexer using the function

> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()

which takes the AST element SrcSpan, the annotation keyword and the
target SrcSpan.

This adds the annotation to the `annotations` field of `PState` and
transfers any comments in `comment_q` WHICH ARE ENCLOSED by
the SrcSpan of this element to the `annotations_comments`
field.  (Comments which are outside of this annotation are deferred
until later. 'allocateComments' in 'Lexer' is responsible for
making sure we only attach comments that actually fit in the 'SrcSpan'.)

The wiki page describing this feature is
https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations

-}
-- ---------------------------------------------------------------------

-- If you update this, update the Note [Api annotations] above
type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]
               , Map.Map SrcSpan [Located AnnotationComment])

-- If you update this, update the Note [Api annotations] above
type ApiAnnKey = (SrcSpan,AnnKeywordId)

-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation.
getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
getAnnotation (anns,_) span ann
   = case Map.lookup (span,ann) anns of
       Nothing -> []
       Just ss -> ss

-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
-- of the annotated AST element, and the known type of the annotation.
-- The list is removed from the annotations.
getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId
                       -> ([SrcSpan],ApiAnns)
getAndRemoveAnnotation (anns,cs) span ann
   = case Map.lookup (span,ann) anns of
       Nothing -> ([],(anns,cs))
       Just ss -> (ss,(Map.delete (span,ann) anns,cs))

-- |Retrieve the comments allocated to the current 'SrcSpan'
--
--  Note: A given 'SrcSpan' may appear in multiple AST elements,
--  beware of duplicates
getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]
getAnnotationComments (_,anns) span =
  case Map.lookup span anns of
    Just cs -> cs
    Nothing -> []

-- |Retrieve the comments allocated to the current 'SrcSpan', and
-- remove them from the annotations
getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan
                               -> ([Located AnnotationComment],ApiAnns)
getAndRemoveAnnotationComments (anns,canns) span =
  case Map.lookup span canns of
    Just cs -> (cs,(anns,Map.delete span canns))
    Nothing -> ([],(anns,canns))

-- --------------------------------------------------------------------

-- | API Annotations exist so that tools can perform source to source
-- conversions of Haskell code. They are used to keep track of the
-- various syntactic keywords that are not captured in the existing
-- AST.
--
-- The annotations, together with original source comments are made
-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.
-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in
-- @'DynFlags.DynFlags'@ before parsing.
--
-- The wiki page describing this feature is
-- https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations
--
-- Note: in general the names of these are taken from the
-- corresponding token, unless otherwise noted
-- See note [Api annotations] above for details of the usage
data AnnKeywordId
    = AnnAnyclass
    | AnnAs
    | AnnAt
    | AnnBang  -- ^ '!'
    | AnnBackquote -- ^ '`'
    | AnnBy
    | AnnCase -- ^ case or lambda case
    | AnnClass
    | AnnClose -- ^  '\#)' or '\#-}'  etc
    | AnnCloseB -- ^ '|)'
    | AnnCloseBU -- ^ '|)', unicode variant
    | AnnCloseC -- ^ '}'
    | AnnCloseQ  -- ^ '|]'
    | AnnCloseQU -- ^ '|]', unicode variant
    | AnnCloseP -- ^ ')'
    | AnnCloseS -- ^ ']'
    | AnnColon
    | AnnComma -- ^ as a list separator
    | AnnCommaTuple -- ^ in a RdrName for a tuple
    | AnnDarrow -- ^ '=>'
    | AnnDarrowU -- ^ '=>', unicode variant
    | AnnData
    | AnnDcolon -- ^ '::'
    | AnnDcolonU -- ^ '::', unicode variant
    | AnnDefault
    | AnnDeriving
    | AnnDo
    | AnnDot    -- ^ '.'
    | AnnDotdot -- ^ '..'
    | AnnElse
    | AnnEqual
    | AnnExport
    | AnnFamily
    | AnnForall
    | AnnForallU -- ^ Unicode variant
    | AnnForeign
    | AnnFunId -- ^ for function name in matches where there are
               -- multiple equations for the function.
    | AnnGroup
    | AnnHeader -- ^ for CType
    | AnnHiding
    | AnnIf
    | AnnImport
    | AnnIn
    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'
    | AnnInstance
    | AnnLam
    | AnnLarrow     -- ^ '<-'
    | AnnLarrowU    -- ^ '<-', unicode variant
    | AnnLet
    | AnnMdo
    | AnnMinus -- ^ '-'
    | AnnModule
    | AnnNewtype
    | AnnName -- ^ where a name loses its location in the AST, this carries it
    | AnnOf
    | AnnOpen    -- ^ '(\#' or '{-\# LANGUAGE' etc
    | AnnOpenB   -- ^ '(|'
    | AnnOpenBU  -- ^ '(|', unicode variant
    | AnnOpenC   -- ^ '{'
    | AnnOpenE   -- ^ '[e|' or '[e||'
    | AnnOpenEQ  -- ^ '[|'
    | AnnOpenEQU -- ^ '[|', unicode variant
    | AnnOpenP   -- ^ '('
    | AnnOpenPE  -- ^ '$('
    | AnnOpenPTE -- ^ '$$('
    | AnnOpenS   -- ^ '['
    | AnnPackageName
    | AnnPattern
    | AnnProc
    | AnnQualified
    | AnnRarrow -- ^ '->'
    | AnnRarrowU -- ^ '->', unicode variant
    | AnnRec
    | AnnRole
    | AnnSafe
    | AnnSemi -- ^ ';'
    | AnnSimpleQuote -- ^ '''
    | AnnSignature
    | AnnStatic -- ^ 'static'
    | AnnStock
    | AnnThen
    | AnnThIdSplice -- ^ '$'
    | AnnThIdTySplice -- ^ '$$'
    | AnnThTyQuote -- ^ double '''
    | AnnTilde -- ^ '~'
    | AnnType
    | AnnUnit -- ^ '()' for types
    | AnnUsing
    | AnnVal  -- ^ e.g. INTEGER
    | AnnValStr  -- ^ String value, will need quotes when output
    | AnnVbar -- ^ '|'
    | AnnVia -- ^ 'via'
    | AnnWhere
    | Annlarrowtail -- ^ '-<'
    | AnnlarrowtailU -- ^ '-<', unicode variant
    | Annrarrowtail -- ^ '->'
    | AnnrarrowtailU -- ^ '->', unicode variant
    | AnnLarrowtail -- ^ '-<<'
    | AnnLarrowtailU -- ^ '-<<', unicode variant
    | AnnRarrowtail -- ^ '>>-'
    | AnnRarrowtailU -- ^ '>>-', unicode variant
    | AnnEofPos
    deriving (Eq, Ord, Data, Show)

instance Outputable AnnKeywordId where
  ppr x = text (show x)

-- ---------------------------------------------------------------------

data AnnotationComment =
  -- Documentation annotations
    AnnDocCommentNext  String     -- ^ something beginning '-- |'
  | AnnDocCommentPrev  String     -- ^ something beginning '-- ^'
  | AnnDocCommentNamed String     -- ^ something beginning '-- $'
  | AnnDocSection      Int String -- ^ a section heading
  | AnnDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)
  | AnnLineComment     String     -- ^ comment starting by "--"
  | AnnBlockComment    String     -- ^ comment in {- -}
    deriving (Eq, Ord, Data, Show)
-- Note: these are based on the Token versions, but the Token type is
-- defined in Lexer.x and bringing it in here would create a loop

instance Outputable AnnotationComment where
  ppr x = text (show x)

-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma',
--             'ApiAnnotation.AnnRarrow'
--             'ApiAnnotation.AnnTilde'
--   - May have 'ApiAnnotation.AnnComma' when in a list
type LRdrName = Located RdrName

-- | Certain tokens can have alternate representations when unicode syntax is
-- enabled. This flag is attached to those tokens in the lexer so that the
-- original source representation can be reproduced in the corresponding
-- 'ApiAnnotation'
data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax
    deriving (Eq, Ord, Data, Show)

-- | Convert a normal annotation into its unicode equivalent one
unicodeAnn :: AnnKeywordId -> AnnKeywordId
unicodeAnn AnnForall     = AnnForallU
unicodeAnn AnnDcolon     = AnnDcolonU
unicodeAnn AnnLarrow     = AnnLarrowU
unicodeAnn AnnRarrow     = AnnRarrowU
unicodeAnn AnnDarrow     = AnnDarrowU
unicodeAnn Annlarrowtail = AnnlarrowtailU
unicodeAnn Annrarrowtail = AnnrarrowtailU
unicodeAnn AnnLarrowtail = AnnLarrowtailU
unicodeAnn AnnRarrowtail = AnnRarrowtailU
unicodeAnn AnnOpenB      = AnnOpenBU
unicodeAnn AnnCloseB     = AnnCloseBU
unicodeAnn AnnOpenEQ     = AnnOpenEQU
unicodeAnn AnnCloseQ     = AnnCloseQU
unicodeAnn ann           = ann

-- | Some template haskell tokens have two variants, one with an `e` the other
-- not:
--
-- >  [| or [e|
-- >  [|| or [e||
--
-- This type indicates whether the 'e' is present or not.
data HasE = HasE | NoE
     deriving (Eq, Ord, Data, Show)


-- Character classification
{-# LANGUAGE CPP #-}
module Ctype
        ( is_ident      -- Char# -> Bool
        , is_symbol     -- Char# -> Bool
        , is_any        -- Char# -> Bool
        , is_space      -- Char# -> Bool
        , is_lower      -- Char# -> Bool
        , is_upper      -- Char# -> Bool
        , is_digit      -- Char# -> Bool
        , is_alphanum   -- Char# -> Bool

        , is_decdigit, is_hexdigit, is_octdigit, is_bindigit
        , hexDigit, octDecDigit
        ) where

#include "HsVersions.h"

import GhcPrelude

import Data.Bits        ( Bits((.&.),(.|.)) )
import Data.Char        ( ord, chr )
import Data.Word
import Panic

-- Bit masks

cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8
cIdent  =  1
cSymbol =  2
cAny    =  4
cSpace  =  8
cLower  = 16
cUpper  = 32
cDigit  = 64

-- | The predicates below look costly, but aren't, GHC+GCC do a great job
-- at the big case below.

{-# INLINABLE is_ctype #-}
is_ctype :: Word8 -> Char -> Bool
is_ctype mask c = (charType c .&. mask) /= 0

is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit,
    is_alphanum :: Char -> Bool
is_ident  = is_ctype cIdent
is_symbol = is_ctype cSymbol
is_any    = is_ctype cAny
is_space  = is_ctype cSpace
is_lower  = is_ctype cLower
is_upper  = is_ctype cUpper
is_digit  = is_ctype cDigit
is_alphanum = is_ctype (cLower+cUpper+cDigit)

-- Utils

hexDigit :: Char -> Int
hexDigit c | is_decdigit c = ord c - ord '0'
           | otherwise     = ord (to_lower c) - ord 'a' + 10

octDecDigit :: Char -> Int
octDecDigit c = ord c - ord '0'

is_decdigit :: Char -> Bool
is_decdigit c
        =  c >= '0' && c <= '9'

is_hexdigit :: Char -> Bool
is_hexdigit c
        =  is_decdigit c
        || (c >= 'a' && c <= 'f')
        || (c >= 'A' && c <= 'F')

is_octdigit :: Char -> Bool
is_octdigit c = c >= '0' && c <= '7'

is_bindigit :: Char -> Bool
is_bindigit c = c == '0' || c == '1'

to_lower :: Char -> Char
to_lower c
  | c >=  'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))
  | otherwise = c

charType :: Char -> Word8
charType c = case c of
   '\0'   -> 0                             -- \000
   '\1'   -> 0                             -- \001
   '\2'   -> 0                             -- \002
   '\3'   -> 0                             -- \003
   '\4'   -> 0                             -- \004
   '\5'   -> 0                             -- \005
   '\6'   -> 0                             -- \006
   '\7'   -> 0                             -- \007
   '\8'   -> 0                             -- \010
   '\9'   -> cSpace                        -- \t  (not allowed in strings, so !cAny)
   '\10'  -> cSpace                        -- \n  (ditto)
   '\11'  -> cSpace                        -- \v  (ditto)
   '\12'  -> cSpace                        -- \f  (ditto)
   '\13'  -> cSpace                        --  ^M (ditto)
   '\14'  -> 0                             -- \016
   '\15'  -> 0                             -- \017
   '\16'  -> 0                             -- \020
   '\17'  -> 0                             -- \021
   '\18'  -> 0                             -- \022
   '\19'  -> 0                             -- \023
   '\20'  -> 0                             -- \024
   '\21'  -> 0                             -- \025
   '\22'  -> 0                             -- \026
   '\23'  -> 0                             -- \027
   '\24'  -> 0                             -- \030
   '\25'  -> 0                             -- \031
   '\26'  -> 0                             -- \032
   '\27'  -> 0                             -- \033
   '\28'  -> 0                             -- \034
   '\29'  -> 0                             -- \035
   '\30'  -> 0                             -- \036
   '\31'  -> 0                             -- \037
   '\32'  -> cAny .|. cSpace               --
   '\33'  -> cAny .|. cSymbol              -- !
   '\34'  -> cAny                          -- "
   '\35'  -> cAny .|. cSymbol              --  #
   '\36'  -> cAny .|. cSymbol              --  $
   '\37'  -> cAny .|. cSymbol              -- %
   '\38'  -> cAny .|. cSymbol              -- &
   '\39'  -> cAny .|. cIdent               -- '
   '\40'  -> cAny                          -- (
   '\41'  -> cAny                          -- )
   '\42'  -> cAny .|. cSymbol              --  *
   '\43'  -> cAny .|. cSymbol              -- +
   '\44'  -> cAny                          -- ,
   '\45'  -> cAny .|. cSymbol              -- -
   '\46'  -> cAny .|. cSymbol              -- .
   '\47'  -> cAny .|. cSymbol              --  /
   '\48'  -> cAny .|. cIdent  .|. cDigit   -- 0
   '\49'  -> cAny .|. cIdent  .|. cDigit   -- 1
   '\50'  -> cAny .|. cIdent  .|. cDigit   -- 2
   '\51'  -> cAny .|. cIdent  .|. cDigit   -- 3
   '\52'  -> cAny .|. cIdent  .|. cDigit   -- 4
   '\53'  -> cAny .|. cIdent  .|. cDigit   -- 5
   '\54'  -> cAny .|. cIdent  .|. cDigit   -- 6
   '\55'  -> cAny .|. cIdent  .|. cDigit   -- 7
   '\56'  -> cAny .|. cIdent  .|. cDigit   -- 8
   '\57'  -> cAny .|. cIdent  .|. cDigit   -- 9
   '\58'  -> cAny .|. cSymbol              -- :
   '\59'  -> cAny                          -- ;
   '\60'  -> cAny .|. cSymbol              -- <
   '\61'  -> cAny .|. cSymbol              -- =
   '\62'  -> cAny .|. cSymbol              -- >
   '\63'  -> cAny .|. cSymbol              -- ?
   '\64'  -> cAny .|. cSymbol              -- @
   '\65'  -> cAny .|. cIdent  .|. cUpper   -- A
   '\66'  -> cAny .|. cIdent  .|. cUpper   -- B
   '\67'  -> cAny .|. cIdent  .|. cUpper   -- C
   '\68'  -> cAny .|. cIdent  .|. cUpper   -- D
   '\69'  -> cAny .|. cIdent  .|. cUpper   -- E
   '\70'  -> cAny .|. cIdent  .|. cUpper   -- F
   '\71'  -> cAny .|. cIdent  .|. cUpper   -- G
   '\72'  -> cAny .|. cIdent  .|. cUpper   -- H
   '\73'  -> cAny .|. cIdent  .|. cUpper   -- I
   '\74'  -> cAny .|. cIdent  .|. cUpper   -- J
   '\75'  -> cAny .|. cIdent  .|. cUpper   -- K
   '\76'  -> cAny .|. cIdent  .|. cUpper   -- L
   '\77'  -> cAny .|. cIdent  .|. cUpper   -- M
   '\78'  -> cAny .|. cIdent  .|. cUpper   -- N
   '\79'  -> cAny .|. cIdent  .|. cUpper   -- O
   '\80'  -> cAny .|. cIdent  .|. cUpper   -- P
   '\81'  -> cAny .|. cIdent  .|. cUpper   -- Q
   '\82'  -> cAny .|. cIdent  .|. cUpper   -- R
   '\83'  -> cAny .|. cIdent  .|. cUpper   -- S
   '\84'  -> cAny .|. cIdent  .|. cUpper   -- T
   '\85'  -> cAny .|. cIdent  .|. cUpper   -- U
   '\86'  -> cAny .|. cIdent  .|. cUpper   -- V
   '\87'  -> cAny .|. cIdent  .|. cUpper   -- W
   '\88'  -> cAny .|. cIdent  .|. cUpper   -- X
   '\89'  -> cAny .|. cIdent  .|. cUpper   -- Y
   '\90'  -> cAny .|. cIdent  .|. cUpper   -- Z
   '\91'  -> cAny                          -- [
   '\92'  -> cAny .|. cSymbol              -- backslash
   '\93'  -> cAny                          -- ]
   '\94'  -> cAny .|. cSymbol              --  ^
   '\95'  -> cAny .|. cIdent  .|. cLower   -- _
   '\96'  -> cAny                          -- `
   '\97'  -> cAny .|. cIdent  .|. cLower   -- a
   '\98'  -> cAny .|. cIdent  .|. cLower   -- b
   '\99'  -> cAny .|. cIdent  .|. cLower   -- c
   '\100' -> cAny .|. cIdent  .|. cLower   -- d
   '\101' -> cAny .|. cIdent  .|. cLower   -- e
   '\102' -> cAny .|. cIdent  .|. cLower   -- f
   '\103' -> cAny .|. cIdent  .|. cLower   -- g
   '\104' -> cAny .|. cIdent  .|. cLower   -- h
   '\105' -> cAny .|. cIdent  .|. cLower   -- i
   '\106' -> cAny .|. cIdent  .|. cLower   -- j
   '\107' -> cAny .|. cIdent  .|. cLower   -- k
   '\108' -> cAny .|. cIdent  .|. cLower   -- l
   '\109' -> cAny .|. cIdent  .|. cLower   -- m
   '\110' -> cAny .|. cIdent  .|. cLower   -- n
   '\111' -> cAny .|. cIdent  .|. cLower   -- o
   '\112' -> cAny .|. cIdent  .|. cLower   -- p
   '\113' -> cAny .|. cIdent  .|. cLower   -- q
   '\114' -> cAny .|. cIdent  .|. cLower   -- r
   '\115' -> cAny .|. cIdent  .|. cLower   -- s
   '\116' -> cAny .|. cIdent  .|. cLower   -- t
   '\117' -> cAny .|. cIdent  .|. cLower   -- u
   '\118' -> cAny .|. cIdent  .|. cLower   -- v
   '\119' -> cAny .|. cIdent  .|. cLower   -- w
   '\120' -> cAny .|. cIdent  .|. cLower   -- x
   '\121' -> cAny .|. cIdent  .|. cLower   -- y
   '\122' -> cAny .|. cIdent  .|. cLower   -- z
   '\123' -> cAny                          -- {
   '\124' -> cAny .|. cSymbol              --  |
   '\125' -> cAny                          -- }
   '\126' -> cAny .|. cSymbol              -- ~
   '\127' -> 0                             -- \177
   _ -> panic ("charType: " ++ show c)


module HaddockUtils where

import GhcPrelude

import HsSyn
import SrcLoc

import Control.Monad

-- -----------------------------------------------------------------------------
-- Adding documentation to record fields (used in parsing).

addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a
addFieldDoc (L l fld) doc
  = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc })

addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a]
addFieldDocs [] _ = []
addFieldDocs (x:xs) doc = addFieldDoc x doc : xs

addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a
addConDoc decl    Nothing = decl
addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )

addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
addConDocs [] _ = []
addConDocs [x] doc = [addConDoc x doc]
addConDocs (x:xs) doc = x : addConDocs xs doc

addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
addConDocFirst [] _ = []
addConDocFirst (x:xs) doc = addConDoc x doc : xs