{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder

module HsExtension where

-- This module captures the type families to precisely identify the extension
-- points for HsSyn

import GhcPrelude

import Data.Data hiding ( Fixity )
import PlaceHolder
import Name
import RdrName
import Var
import Outputable
import SrcLoc (Located)

import Data.Kind

{-
Note [Trees that grow]
~~~~~~~~~~~~~~~~~~~~~~

See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

The hsSyn AST is reused across multiple compiler passes. We also have the
Template Haskell AST, and the haskell-src-exts one (outside of GHC)

Supporting multiple passes means the AST has various warts on it to cope with
the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut',
'SigPatOut' etc.

The growable AST will allow each of these variants to be captured explicitly,
such that they only exist in the given compiler pass AST, as selected by the
type parameter to the AST.

In addition it will allow tool writers to define their own extensions to capture
additional information for the tool, in a natural way.

A further goal is to provide a means to harmonise the Template Haskell and
haskell-src-exts ASTs as well.

-}

-- | used as place holder in TTG values
data NoExt = NoExt
  deriving (Data,Eq,Ord)

instance Outputable NoExt where
  ppr _ = text "NoExt"

-- | Used when constructing a term with an unused extension point.
noExt :: NoExt
noExt = NoExt

-- | Used as a data type index for the hsSyn AST
data GhcPass (c :: Pass)
deriving instance Eq (GhcPass c)
deriving instance Typeable c => Data (GhcPass c)

data Pass = Parsed | Renamed | Typechecked
         deriving (Data)

-- Type synonyms as a shorthand for tagging
type GhcPs   = GhcPass 'Parsed      -- Old 'RdrName' type param
type GhcRn   = GhcPass 'Renamed     -- Old 'Name' type param
type GhcTc   = GhcPass 'Typechecked -- Old 'Id' type para,
type GhcTcId = GhcTc                -- Old 'TcId' type param

-- | Maps the "normal" id type for a given pass
type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id

type LIdP p = Located (IdP p)

-- | Marks that a field uses the GhcRn variant even when the pass
-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because
-- HsType GhcTc should never occur.
type family NoGhcTc (p :: Type) where
    -- this way, GHC can figure out that the result is a GhcPass
  NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)
  NoGhcTc other          = other

type family NoGhcTcPass (p :: Pass) :: Pass where
  NoGhcTcPass 'Typechecked = 'Renamed
  NoGhcTcPass other        = other

-- =====================================================================
-- Type families for the HsBinds extension points

-- HsLocalBindsLR type families
type family XHsValBinds      x x'
type family XHsIPBinds       x x'
type family XEmptyLocalBinds x x'
type family XXHsLocalBindsLR x x'

type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
       ( c (XHsValBinds      x x')
       , c (XHsIPBinds       x x')
       , c (XEmptyLocalBinds x x')
       , c (XXHsLocalBindsLR x x')
       )

-- ValBindsLR type families
type family XValBinds    x x'
type family XXValBindsLR x x'

type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
       ( c (XValBinds    x x')
       , c (XXValBindsLR x x')
       )

-- HsBindsLR type families
type family XFunBind    x x'
type family XPatBind    x x'
type family XVarBind    x x'
type family XAbsBinds   x x'
type family XPatSynBind x x'
type family XXHsBindsLR x x'

type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
       ( c (XFunBind    x x')
       , c (XPatBind    x x')
       , c (XVarBind    x x')
       , c (XAbsBinds   x x')
       , c (XPatSynBind x x')
       , c (XXHsBindsLR x x')
       )

-- ABExport type families
type family XABE x
type family XXABExport x

type ForallXABExport (c :: * -> Constraint) (x :: *) =
       ( c (XABE       x)
       , c (XXABExport x)
       )

-- PatSynBind type families
type family XPSB x x'
type family XXPatSynBind x x'

type ForallXPatSynBind  (c :: * -> Constraint) (x :: *) (x' :: *) =
       ( c (XPSB         x x')
       , c (XXPatSynBind x x')
       )

-- HsIPBinds type families
type family XIPBinds    x
type family XXHsIPBinds x

type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
       ( c (XIPBinds    x)
       , c (XXHsIPBinds x)
       )

-- IPBind type families
type family XCIPBind x
type family XXIPBind x

type ForallXIPBind (c :: * -> Constraint) (x :: *) =
       ( c (XCIPBind x)
       , c (XXIPBind x)
       )

-- Sig type families
type family XTypeSig          x
type family XPatSynSig        x
type family XClassOpSig       x
type family XIdSig            x
type family XFixSig           x
type family XInlineSig        x
type family XSpecSig          x
type family XSpecInstSig      x
type family XMinimalSig       x
type family XSCCFunSig        x
type family XCompleteMatchSig x
type family XXSig             x

type ForallXSig (c :: * -> Constraint) (x :: *) =
       ( c (XTypeSig          x)
       , c (XPatSynSig        x)
       , c (XClassOpSig       x)
       , c (XIdSig            x)
       , c (XFixSig           x)
       , c (XInlineSig        x)
       , c (XSpecSig          x)
       , c (XSpecInstSig      x)
       , c (XMinimalSig       x)
       , c (XSCCFunSig        x)
       , c (XCompleteMatchSig x)
       , c (XXSig             x)
       )

-- FixitySig type families
type family XFixitySig          x
type family XXFixitySig         x

type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
       ( c (XFixitySig         x)
       , c (XXFixitySig        x)
       )

-- =====================================================================
-- Type families for the HsDecls extension points

-- HsDecl type families
type family XTyClD       x
type family XInstD       x
type family XDerivD      x
type family XValD        x
type family XSigD        x
type family XDefD        x
type family XForD        x
type family XWarningD    x
type family XAnnD        x
type family XRuleD       x
type family XSpliceD     x
type family XDocD        x
type family XRoleAnnotD  x
type family XXHsDecl     x

type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
       ( c (XTyClD       x)
       , c (XInstD       x)
       , c (XDerivD      x)
       , c (XValD        x)
       , c (XSigD        x)
       , c (XDefD        x)
       , c (XForD        x)
       , c (XWarningD    x)
       , c (XAnnD        x)
       , c (XRuleD       x)
       , c (XSpliceD     x)
       , c (XDocD        x)
       , c (XRoleAnnotD  x)
       , c (XXHsDecl    x)
       )

-- -------------------------------------
-- HsGroup type families
type family XCHsGroup      x
type family XXHsGroup      x

type ForallXHsGroup (c :: * -> Constraint) (x :: *) =
       ( c (XCHsGroup       x)
       , c (XXHsGroup       x)
       )

-- -------------------------------------
-- SpliceDecl type families
type family XSpliceDecl       x
type family XXSpliceDecl      x

type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) =
       ( c (XSpliceDecl        x)
       , c (XXSpliceDecl       x)
       )

-- -------------------------------------
-- TyClDecl type families
type family XFamDecl       x
type family XSynDecl       x
type family XDataDecl      x
type family XClassDecl     x
type family XXTyClDecl     x

type ForallXTyClDecl (c :: * -> Constraint) (x :: *) =
       ( c (XFamDecl       x)
       , c (XSynDecl       x)
       , c (XDataDecl      x)
       , c (XClassDecl     x)
       , c (XXTyClDecl     x)
       )

-- -------------------------------------
-- TyClGroup type families
type family XCTyClGroup      x
type family XXTyClGroup      x

type ForallXTyClGroup (c :: * -> Constraint) (x :: *) =
       ( c (XCTyClGroup       x)
       , c (XXTyClGroup       x)
       )

-- -------------------------------------
-- FamilyResultSig type families
type family XNoSig            x
type family XCKindSig         x -- Clashes with XKindSig above
type family XTyVarSig         x
type family XXFamilyResultSig x

type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) =
       ( c (XNoSig            x)
       , c (XCKindSig         x)
       , c (XTyVarSig         x)
       , c (XXFamilyResultSig x)
       )

-- -------------------------------------
-- FamilyDecl type families
type family XCFamilyDecl      x
type family XXFamilyDecl      x

type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCFamilyDecl       x)
       , c (XXFamilyDecl       x)
       )

-- -------------------------------------
-- HsDataDefn type families
type family XCHsDataDefn      x
type family XXHsDataDefn      x

type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) =
       ( c (XCHsDataDefn       x)
       , c (XXHsDataDefn       x)
       )

-- -------------------------------------
-- HsDerivingClause type families
type family XCHsDerivingClause      x
type family XXHsDerivingClause      x

type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) =
       ( c (XCHsDerivingClause       x)
       , c (XXHsDerivingClause       x)
       )

-- -------------------------------------
-- ConDecl type families
type family XConDeclGADT   x
type family XConDeclH98    x
type family XXConDecl      x

type ForallXConDecl (c :: * -> Constraint) (x :: *) =
       ( c (XConDeclGADT    x)
       , c (XConDeclH98     x)
       , c (XXConDecl       x)
       )

-- -------------------------------------
-- FamEqn type families
type family XCFamEqn      x p r
type family XXFamEqn      x p r

type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) =
       ( c (XCFamEqn       x p r)
       , c (XXFamEqn       x p r)
       )

-- -------------------------------------
-- ClsInstDecl type families
type family XCClsInstDecl      x
type family XXClsInstDecl      x

type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCClsInstDecl       x)
       , c (XXClsInstDecl       x)
       )

-- -------------------------------------
-- ClsInstDecl type families
type family XClsInstD      x
type family XDataFamInstD  x
type family XTyFamInstD    x
type family XXInstDecl     x

type ForallXInstDecl (c :: * -> Constraint) (x :: *) =
       ( c (XClsInstD       x)
       , c (XDataFamInstD   x)
       , c (XTyFamInstD     x)
       , c (XXInstDecl      x)
       )

-- -------------------------------------
-- DerivDecl type families
type family XCDerivDecl      x
type family XXDerivDecl      x

type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCDerivDecl       x)
       , c (XXDerivDecl       x)
       )

-- -------------------------------------
-- DerivStrategy type family
type family XViaStrategy x

-- -------------------------------------
-- DefaultDecl type families
type family XCDefaultDecl      x
type family XXDefaultDecl      x

type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCDefaultDecl       x)
       , c (XXDefaultDecl       x)
       )

-- -------------------------------------
-- DefaultDecl type families
type family XForeignImport     x
type family XForeignExport     x
type family XXForeignDecl      x

type ForallXForeignDecl (c :: * -> Constraint) (x :: *) =
       ( c (XForeignImport      x)
       , c (XForeignExport      x)
       , c (XXForeignDecl       x)
       )

-- -------------------------------------
-- RuleDecls type families
type family XCRuleDecls      x
type family XXRuleDecls      x

type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
       ( c (XCRuleDecls       x)
       , c (XXRuleDecls       x)
       )

-- -------------------------------------
-- RuleDecl type families
type family XHsRule          x
type family XXRuleDecl       x

type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
       ( c (XHsRule           x)
       , c (XXRuleDecl        x)
       )

-- -------------------------------------
-- RuleBndr type families
type family XCRuleBndr      x
type family XRuleBndrSig    x
type family XXRuleBndr      x

type ForallXRuleBndr (c :: * -> Constraint) (x :: *) =
       ( c (XCRuleBndr       x)
       , c (XRuleBndrSig     x)
       , c (XXRuleBndr       x)
       )

-- -------------------------------------
-- WarnDecls type families
type family XWarnings        x
type family XXWarnDecls      x

type ForallXWarnDecls (c :: * -> Constraint) (x :: *) =
       ( c (XWarnings        x)
       , c (XXWarnDecls      x)
       )

-- -------------------------------------
-- AnnDecl type families
type family XWarning        x
type family XXWarnDecl      x

type ForallXWarnDecl (c :: * -> Constraint) (x :: *) =
       ( c (XWarning        x)
       , c (XXWarnDecl      x)
       )

-- -------------------------------------
-- AnnDecl type families
type family XHsAnnotation  x
type family XXAnnDecl      x

type ForallXAnnDecl (c :: * -> Constraint) (x :: *) =
       ( c (XHsAnnotation  x)
       , c (XXAnnDecl      x)
       )

-- -------------------------------------
-- RoleAnnotDecl type families
type family XCRoleAnnotDecl  x
type family XXRoleAnnotDecl  x

type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCRoleAnnotDecl  x)
       , c (XXRoleAnnotDecl  x)
       )

-- =====================================================================
-- Type families for the HsExpr extension points

type family XVar            x
type family XUnboundVar     x
type family XConLikeOut     x
type family XRecFld         x
type family XOverLabel      x
type family XIPVar          x
type family XOverLitE       x
type family XLitE           x
type family XLam            x
type family XLamCase        x
type family XApp            x
type family XAppTypeE       x
type family XOpApp          x
type family XNegApp         x
type family XPar            x
type family XSectionL       x
type family XSectionR       x
type family XExplicitTuple  x
type family XExplicitSum    x
type family XCase           x
type family XIf             x
type family XMultiIf        x
type family XLet            x
type family XDo             x
type family XExplicitList   x
type family XRecordCon      x
type family XRecordUpd      x
type family XExprWithTySig  x
type family XArithSeq       x
type family XSCC            x
type family XCoreAnn        x
type family XBracket        x
type family XRnBracketOut   x
type family XTcBracketOut   x
type family XSpliceE        x
type family XProc           x
type family XStatic         x
type family XArrApp         x
type family XArrForm        x
type family XTick           x
type family XBinTick        x
type family XTickPragma     x
type family XEWildPat       x
type family XEAsPat         x
type family XEViewPat       x
type family XELazyPat       x
type family XWrap           x
type family XXExpr          x

type ForallXExpr (c :: * -> Constraint) (x :: *) =
       ( c (XVar            x)
       , c (XUnboundVar     x)
       , c (XConLikeOut     x)
       , c (XRecFld         x)
       , c (XOverLabel      x)
       , c (XIPVar          x)
       , c (XOverLitE       x)
       , c (XLitE           x)
       , c (XLam            x)
       , c (XLamCase        x)
       , c (XApp            x)
       , c (XAppTypeE       x)
       , c (XOpApp          x)
       , c (XNegApp         x)
       , c (XPar            x)
       , c (XSectionL       x)
       , c (XSectionR       x)
       , c (XExplicitTuple  x)
       , c (XExplicitSum    x)
       , c (XCase           x)
       , c (XIf             x)
       , c (XMultiIf        x)
       , c (XLet            x)
       , c (XDo             x)
       , c (XExplicitList   x)
       , c (XRecordCon      x)
       , c (XRecordUpd      x)
       , c (XExprWithTySig  x)
       , c (XArithSeq       x)
       , c (XSCC            x)
       , c (XCoreAnn        x)
       , c (XBracket        x)
       , c (XRnBracketOut   x)
       , c (XTcBracketOut   x)
       , c (XSpliceE        x)
       , c (XProc           x)
       , c (XStatic         x)
       , c (XArrApp         x)
       , c (XArrForm        x)
       , c (XTick           x)
       , c (XBinTick        x)
       , c (XTickPragma     x)
       , c (XEWildPat       x)
       , c (XEAsPat         x)
       , c (XEViewPat       x)
       , c (XELazyPat       x)
       , c (XWrap           x)
       , c (XXExpr          x)
       )
-- ---------------------------------------------------------------------

type family XUnambiguous        x
type family XAmbiguous          x
type family XXAmbiguousFieldOcc x

type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
       ( c (XUnambiguous        x)
       , c (XAmbiguous          x)
       , c (XXAmbiguousFieldOcc x)
       )

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

type family XPresent  x
type family XMissing  x
type family XXTupArg  x

type ForallXTupArg (c :: * -> Constraint) (x :: *) =
       ( c (XPresent x)
       , c (XMissing x)
       , c (XXTupArg x)
       )

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

type family XTypedSplice   x
type family XUntypedSplice x
type family XQuasiQuote    x
type family XSpliced       x
type family XXSplice       x

type ForallXSplice (c :: * -> Constraint) (x :: *) =
       ( c (XTypedSplice   x)
       , c (XUntypedSplice x)
       , c (XQuasiQuote    x)
       , c (XSpliced       x)
       , c (XXSplice       x)
       )

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

type family XExpBr      x
type family XPatBr      x
type family XDecBrL     x
type family XDecBrG     x
type family XTypBr      x
type family XVarBr      x
type family XTExpBr     x
type family XXBracket   x

type ForallXBracket (c :: * -> Constraint) (x :: *) =
       ( c (XExpBr      x)
       , c (XPatBr      x)
       , c (XDecBrL     x)
       , c (XDecBrG     x)
       , c (XTypBr      x)
       , c (XVarBr      x)
       , c (XTExpBr     x)
       , c (XXBracket   x)
       )

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

type family XCmdTop  x
type family XXCmdTop x

type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
       ( c (XCmdTop  x)
       , c (XXCmdTop x)
       )

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

type family XMG           x b
type family XXMatchGroup  x b

type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XMG          x b)
       , c (XXMatchGroup x b)
       )

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

type family XCMatch  x b
type family XXMatch  x b

type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XCMatch  x b)
       , c (XXMatch  x b)
       )

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

type family XCGRHSs  x b
type family XXGRHSs  x b

type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XCGRHSs  x b)
       , c (XXGRHSs  x b)
       )

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

type family XCGRHS  x b
type family XXGRHS  x b

type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XCGRHS  x b)
       , c (XXGRHS  x b)
       )

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

type family XLastStmt        x x' b
type family XBindStmt        x x' b
type family XApplicativeStmt x x' b
type family XBodyStmt        x x' b
type family XLetStmt         x x' b
type family XParStmt         x x' b
type family XTransStmt       x x' b
type family XRecStmt         x x' b
type family XXStmtLR         x x' b

type ForallXStmtLR (c :: * -> Constraint) (x :: *)  (x' :: *) (b :: *) =
       ( c (XLastStmt         x x' b)
       , c (XBindStmt         x x' b)
       , c (XApplicativeStmt  x x' b)
       , c (XBodyStmt         x x' b)
       , c (XLetStmt          x x' b)
       , c (XParStmt          x x' b)
       , c (XTransStmt        x x' b)
       , c (XRecStmt          x x' b)
       , c (XXStmtLR          x x' b)
       )

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

type family XCmdArrApp  x
type family XCmdArrForm x
type family XCmdApp     x
type family XCmdLam     x
type family XCmdPar     x
type family XCmdCase    x
type family XCmdIf      x
type family XCmdLet     x
type family XCmdDo      x
type family XCmdWrap    x
type family XXCmd       x

type ForallXCmd (c :: * -> Constraint) (x :: *) =
       ( c (XCmdArrApp  x)
       , c (XCmdArrForm x)
       , c (XCmdApp     x)
       , c (XCmdLam     x)
       , c (XCmdPar     x)
       , c (XCmdCase    x)
       , c (XCmdIf      x)
       , c (XCmdLet     x)
       , c (XCmdDo      x)
       , c (XCmdWrap    x)
       , c (XXCmd       x)
       )

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

type family XParStmtBlock  x x'
type family XXParStmtBlock x x'

type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
       ( c (XParStmtBlock  x x')
       , c (XXParStmtBlock x x')
       )

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

type family XApplicativeArgOne   x
type family XApplicativeArgMany  x
type family XXApplicativeArg     x

type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) =
       ( c (XApplicativeArgOne   x)
       , c (XApplicativeArgMany  x)
       , c (XXApplicativeArg     x)
       )

-- =====================================================================
-- Type families for the HsImpExp extension points

-- TODO

-- =====================================================================
-- Type families for the HsLit extension points

-- We define a type family for each extension point. This is based on prepending
-- 'X' to the constructor name, for ease of reference.
type family XHsChar x
type family XHsCharPrim x
type family XHsString x
type family XHsStringPrim x
type family XHsInt x
type family XHsIntPrim x
type family XHsWordPrim x
type family XHsInt64Prim x
type family XHsWord64Prim x
type family XHsInteger x
type family XHsRat x
type family XHsFloatPrim x
type family XHsDoublePrim x
type family XXLit x

-- | Helper to apply a constraint to all extension points. It has one
-- entry per extension point type family.
type ForallXHsLit (c :: * -> Constraint) (x :: *) =
  ( c (XHsChar       x)
  , c (XHsCharPrim   x)
  , c (XHsDoublePrim x)
  , c (XHsFloatPrim  x)
  , c (XHsInt        x)
  , c (XHsInt64Prim  x)
  , c (XHsIntPrim    x)
  , c (XHsInteger    x)
  , c (XHsRat        x)
  , c (XHsString     x)
  , c (XHsStringPrim x)
  , c (XHsWord64Prim x)
  , c (XHsWordPrim   x)
  , c (XXLit         x)
  )

type family XOverLit  x
type family XXOverLit x

type ForallXOverLit (c :: * -> Constraint) (x :: *) =
       ( c (XOverLit  x)
       , c (XXOverLit x)
       )

-- =====================================================================
-- Type families for the HsPat extension points

type family XWildPat   x
type family XVarPat    x
type family XLazyPat   x
type family XAsPat     x
type family XParPat    x
type family XBangPat   x
type family XListPat   x
type family XTuplePat  x
type family XSumPat    x
type family XConPat    x
type family XViewPat   x
type family XSplicePat x
type family XLitPat    x
type family XNPat      x
type family XNPlusKPat x
type family XSigPat    x
type family XCoPat     x
type family XXPat      x

type ForallXPat (c :: * -> Constraint) (x :: *) =
       ( c (XWildPat   x)
       , c (XVarPat    x)
       , c (XLazyPat   x)
       , c (XAsPat     x)
       , c (XParPat    x)
       , c (XBangPat   x)
       , c (XListPat   x)
       , c (XTuplePat  x)
       , c (XSumPat    x)
       , c (XViewPat   x)
       , c (XSplicePat x)
       , c (XLitPat    x)
       , c (XNPat      x)
       , c (XNPlusKPat x)
       , c (XSigPat    x)
       , c (XCoPat     x)
       , c (XXPat      x)
       )

-- =====================================================================
-- Type families for the HsTypes type families

type family XHsQTvs       x
type family XXLHsQTyVars  x

type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) =
       ( c (XHsQTvs       x)
       , c (XXLHsQTyVars  x)
       )

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

type family XHsIB              x b
type family XXHsImplicitBndrs  x b

type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XHsIB              x b)
       , c (XXHsImplicitBndrs  x b)
       )

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

type family XHsWC              x b
type family XXHsWildCardBndrs  x b

type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) =
       ( c (XHsWC              x b)
       , c (XXHsWildCardBndrs  x b)
       )

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

type family XForAllTy        x
type family XQualTy          x
type family XTyVar           x
type family XAppTy           x
type family XAppKindTy       x
type family XFunTy           x
type family XListTy          x
type family XTupleTy         x
type family XSumTy           x
type family XOpTy            x
type family XParTy           x
type family XIParamTy        x
type family XStarTy          x
type family XKindSig         x
type family XSpliceTy        x
type family XDocTy           x
type family XBangTy          x
type family XRecTy           x
type family XExplicitListTy  x
type family XExplicitTupleTy x
type family XTyLit           x
type family XWildCardTy      x
type family XXType           x

-- | Helper to apply a constraint to all extension points. It has one
-- entry per extension point type family.
type ForallXType (c :: * -> Constraint) (x :: *) =
       ( c (XForAllTy        x)
       , c (XQualTy          x)
       , c (XTyVar           x)
       , c (XAppTy           x)
       , c (XAppKindTy       x)
       , c (XFunTy           x)
       , c (XListTy          x)
       , c (XTupleTy         x)
       , c (XSumTy           x)
       , c (XOpTy            x)
       , c (XParTy           x)
       , c (XIParamTy        x)
       , c (XStarTy          x)
       , c (XKindSig         x)
       , c (XSpliceTy        x)
       , c (XDocTy           x)
       , c (XBangTy          x)
       , c (XRecTy           x)
       , c (XExplicitListTy  x)
       , c (XExplicitTupleTy x)
       , c (XTyLit           x)
       , c (XWildCardTy      x)
       , c (XXType           x)
       )

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

type family XUserTyVar   x
type family XKindedTyVar x
type family XXTyVarBndr  x

type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
       ( c (XUserTyVar      x)
       , c (XKindedTyVar    x)
       , c (XXTyVarBndr     x)
       )

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

type family XConDeclField  x
type family XXConDeclField x

type ForallXConDeclField (c :: * -> Constraint) (x :: *) =
       ( c (XConDeclField  x)
       , c (XXConDeclField x)
       )

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

type family XCFieldOcc x
type family XXFieldOcc x

type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
       ( c (XCFieldOcc x)
       , c (XXFieldOcc x)
       )

-- =====================================================================
-- Type families for the HsImpExp type families

type family XCImportDecl       x
type family XXImportDecl       x

type ForallXImportDecl (c :: * -> Constraint) (x :: *) =
       ( c (XCImportDecl x)
       , c (XXImportDecl x)
       )

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

type family XIEVar             x
type family XIEThingAbs        x
type family XIEThingAll        x
type family XIEThingWith       x
type family XIEModuleContents  x
type family XIEGroup           x
type family XIEDoc             x
type family XIEDocNamed        x
type family XXIE               x

type ForallXIE (c :: * -> Constraint) (x :: *) =
       ( c (XIEVar x)
       , c (XIEThingAbs        x)
       , c (XIEThingAll        x)
       , c (XIEThingWith       x)
       , c (XIEModuleContents  x)
       , c (XIEGroup           x)
       , c (XIEDoc             x)
       , c (XIEDocNamed        x)
       , c (XXIE               x)
       )

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

-- =====================================================================
-- End of Type family definitions
-- =====================================================================

-- ----------------------------------------------------------------------
-- | Conversion of annotations from one type index to another. This is required
-- where the AST is converted from one pass to another, and the extension values
-- need to be brought along if possible. So for example a 'SourceText' is
-- converted via 'id', but needs a type signature to keep the type checker
-- happy.
class Convertable a b  | a -> b where
  convert :: a -> b

instance Convertable a a where
  convert = id

-- | A constraint capturing all the extension points that can be converted via
-- @instance Convertable a a@
type ConvertIdX a b =
  (XHsDoublePrim a ~ XHsDoublePrim b,
   XHsFloatPrim a ~ XHsFloatPrim b,
   XHsRat a ~ XHsRat b,
   XHsInteger a ~ XHsInteger b,
   XHsWord64Prim a ~ XHsWord64Prim b,
   XHsInt64Prim a ~ XHsInt64Prim b,
   XHsWordPrim a ~ XHsWordPrim b,
   XHsIntPrim a ~ XHsIntPrim b,
   XHsInt a ~ XHsInt b,
   XHsStringPrim a ~ XHsStringPrim b,
   XHsString a ~ XHsString b,
   XHsCharPrim a ~ XHsCharPrim b,
   XHsChar a ~ XHsChar b,
   XXLit a ~ XXLit b)

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

-- Note [OutputableX]
-- ~~~~~~~~~~~~~~~~~~
--
-- is required because the type family resolution
-- process cannot determine that all cases are handled for a `GhcPass p`
-- case where the cases are listed separately.
--
-- So
--
--   type instance XXHsIPBinds    (GhcPass p) = NoExt
--
-- will correctly deduce Outputable for (GhcPass p), but
--
--   type instance XIPBinds       GhcPs = NoExt
--   type instance XIPBinds       GhcRn = NoExt
--   type instance XIPBinds       GhcTc = TcEvBinds
--
-- will not.

-- | Provide a summary constraint that gives all am Outputable constraint to
-- extension points needing one
type OutputableX p = -- See Note [OutputableX]
  ( Outputable (XIPBinds    p)
  , Outputable (XViaStrategy p)
  , Outputable (XViaStrategy GhcRn)
  )
-- TODO: Should OutputableX be included in OutputableBndrId?

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

-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
-- the @id@ and the 'NameOrRdrName' type for it
type OutputableBndrId id =
  ( OutputableBndr (NameOrRdrName (IdP id))
  , OutputableBndr (IdP id)
  , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id)))
  , OutputableBndr (IdP (NoGhcTc id))
  , NoGhcTc id ~ NoGhcTc (NoGhcTc id)
  , OutputableX id
  , OutputableX (NoGhcTc id)
  )


{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

HsImpExp: Abstract syntax: imports, exports, interfaces
-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder

module HsImpExp where

import GhcPrelude

import Module           ( ModuleName )
import HsDoc            ( HsDocString )
import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
import BasicTypes       ( SourceText(..), StringLiteral(..), pprWithSourceText )
import FieldLabel       ( FieldLbl(..) )

import Outputable
import FastString
import SrcLoc
import HsExtension

import Data.Data

{-
************************************************************************
*                                                                      *
\subsection{Import and export declaration lists}
*                                                                      *
************************************************************************

One per \tr{import} declaration in a module.
-}

-- | Located Import Declaration
type LImportDecl pass = Located (ImportDecl pass)
        -- ^ When in a list this may have
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'

        -- For details on above see note [Api annotations] in ApiAnnotation

-- | Import Declaration
--
-- A single Haskell @import@ declaration.
data ImportDecl pass
  = ImportDecl {
      ideclExt       :: XCImportDecl pass,
      ideclSourceSrc :: SourceText,
                                 -- Note [Pragma source text] in BasicTypes
      ideclName      :: Located ModuleName, -- ^ Module name.
      ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.
      ideclSource    :: Bool,          -- ^ True <=> {-\# SOURCE \#-} import
      ideclSafe      :: Bool,          -- ^ True => safe import
      ideclQualified :: Bool,          -- ^ True => qualified
      ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)
      ideclAs        :: Maybe (Located ModuleName),  -- ^ as Module
      ideclHiding    :: Maybe (Bool, Located [LIE pass])
                                       -- ^ (True => hiding, names)
    }
  | XImportDecl (XXImportDecl pass)
     -- ^
     --  'ApiAnnotation.AnnKeywordId's
     --
     --  - 'ApiAnnotation.AnnImport'
     --
     --  - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource
     --
     --  - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified',
     --    'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs',
     --    'ApiAnnotation.AnnVal'
     --
     --  - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen',
     --    'ApiAnnotation.AnnClose' attached
     --     to location in ideclHiding

     -- For details on above see note [Api annotations] in ApiAnnotation

type instance XCImportDecl  (GhcPass _) = NoExt
type instance XXImportDecl  (GhcPass _) = NoExt

simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl mn = ImportDecl {
      ideclExt       = noExt,
      ideclSourceSrc = NoSourceText,
      ideclName      = noLoc mn,
      ideclPkgQual   = Nothing,
      ideclSource    = False,
      ideclSafe      = False,
      ideclImplicit  = False,
      ideclQualified = False,
      ideclAs        = Nothing,
      ideclHiding    = Nothing
    }

instance (p ~ GhcPass pass,OutputableBndrId p)
       => Outputable (ImportDecl p) where
    ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
                    , ideclPkgQual = pkg
                    , ideclSource = from, ideclSafe = safe
                    , ideclQualified = qual, ideclImplicit = implicit
                    , ideclAs = as, ideclHiding = spec })
      = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,
                    pp_qual qual, pp_pkg pkg, ppr mod', pp_as as])
             4 (pp_spec spec)
      where
        pp_implicit False = empty
        pp_implicit True = ptext (sLit ("(implicit)"))

        pp_pkg Nothing                    = empty
        pp_pkg (Just (StringLiteral st p))
          = pprWithSourceText st (doubleQuotes (ftext p))

        pp_qual False   = empty
        pp_qual True    = text "qualified"

        pp_safe False   = empty
        pp_safe True    = text "safe"

        pp_as Nothing   = empty
        pp_as (Just a)  = text "as" <+> ppr a

        ppr_imp True  = case mSrcText of
                          NoSourceText   -> text "{-# SOURCE #-}"
                          SourceText src -> text src <+> text "#-}"
        ppr_imp False = empty

        pp_spec Nothing             = empty
        pp_spec (Just (False, (L _ ies))) = ppr_ies ies
        pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies

        ppr_ies []  = text "()"
        ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
    ppr (XImportDecl x) = ppr x

{-
************************************************************************
*                                                                      *
\subsection{Imported and exported entities}
*                                                                      *
************************************************************************
-}

-- | A name in an import or export specification which may have adornments. Used
-- primarily for accurate pretty printing of ParsedSource, and API Annotation
-- placement.
data IEWrappedName name
  = IEName    (Located name)  -- ^ no extra
  | IEPattern (Located name)  -- ^ pattern X
  | IEType    (Located name)  -- ^ type (:+:)
  deriving (Eq,Data)

-- | Located name with possible adornment
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType',
--         'ApiAnnotation.AnnPattern'
type LIEWrappedName name = Located (IEWrappedName name)
-- For details on above see note [Api annotations] in ApiAnnotation

-- | Located Import or Export
type LIE pass = Located (IE pass)
        -- ^ When in a list this may have
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'

        -- For details on above see note [Api annotations] in ApiAnnotation

-- | Imported or exported entity.
data IE pass
  = IEVar       (XIEVar pass) (LIEWrappedName (IdP pass))
        -- ^ Imported or Exported Variable

  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName (IdP pass))
        -- ^ Imported or exported Thing with Absent list
        --
        -- The thing is a Class/Type (can't tell)
        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
        --             'ApiAnnotation.AnnType','ApiAnnotation.AnnVal'

        -- For details on above see note [Api annotations] in ApiAnnotation
        -- See Note [Located RdrNames] in HsExpr
  | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))
        -- ^ Imported or exported Thing with All imported or exported
        --
        -- The thing is a Class/Type and the All refers to methods/constructors
        --
        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
        --       'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose',
        --                                 'ApiAnnotation.AnnType'

        -- For details on above see note [Api annotations] in ApiAnnotation
        -- See Note [Located RdrNames] in HsExpr

  | IEThingWith (XIEThingWith pass)
                (LIEWrappedName (IdP pass))
                IEWildcard
                [LIEWrappedName (IdP pass)]
                [Located (FieldLbl (IdP pass))]
        -- ^ Imported or exported Thing With given imported or exported
        --
        -- The thing is a Class/Type and the imported or exported things are
        -- methods/constructors and record fields; see Note [IEThingWith]
        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
        --                                   'ApiAnnotation.AnnClose',
        --                                   'ApiAnnotation.AnnComma',
        --                                   'ApiAnnotation.AnnType'

        -- For details on above see note [Api annotations] in ApiAnnotation
  | IEModuleContents  (XIEModuleContents pass) (Located ModuleName)
        -- ^ Imported or exported module contents
        --
        -- (Export Only)
        --
        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'

        -- For details on above see note [Api annotations] in ApiAnnotation
  | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading
  | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation
  | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc
  | XIE (XXIE pass)

type instance XIEVar             (GhcPass _) = NoExt
type instance XIEThingAbs        (GhcPass _) = NoExt
type instance XIEThingAll        (GhcPass _) = NoExt
type instance XIEThingWith       (GhcPass _) = NoExt
type instance XIEModuleContents  (GhcPass _) = NoExt
type instance XIEGroup           (GhcPass _) = NoExt
type instance XIEDoc             (GhcPass _) = NoExt
type instance XIEDocNamed        (GhcPass _) = NoExt
type instance XXIE               (GhcPass _) = NoExt

-- | Imported or Exported Wildcard
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)

{-
Note [IEThingWith]
~~~~~~~~~~~~~~~~~~

A definition like

    module M ( T(MkT, x) ) where
      data T = MkT { x :: Int }

gives rise to

    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)
    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)

See Note [Representing fields in AvailInfo] in Avail for more details.
-}

ieName :: IE pass -> IdP pass
ieName (IEVar _ (L _ n))              = ieWrappedName n
ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n
ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n
ieName (IEThingAll  _ (L _ n))        = ieWrappedName n
ieName _ = panic "ieName failed pattern match!"

ieNames :: IE pass -> [IdP pass]
ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]
ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]
ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]
ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n
                                       : map (ieWrappedName . unLoc) ns
ieNames (IEModuleContents {})     = []
ieNames (IEGroup          {})     = []
ieNames (IEDoc            {})     = []
ieNames (IEDocNamed       {})     = []
ieNames (XIE {}) = panic "ieNames"

ieWrappedName :: IEWrappedName name -> name
ieWrappedName (IEName    (L _ n)) = n
ieWrappedName (IEPattern (L _ n)) = n
ieWrappedName (IEType    (L _ n)) = n

lieWrappedName :: LIEWrappedName name -> name
lieWrappedName (L _ n) = ieWrappedName n

ieLWrappedName :: LIEWrappedName name -> Located name
ieLWrappedName (L l n) = L l (ieWrappedName n)

replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2
replaceWrappedName (IEName    (L l _)) n = IEName    (L l n)
replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)
replaceWrappedName (IEType    (L l _)) n = IEType    (L l n)

replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')

instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
    ppr (IEVar       _     var) = ppr (unLoc var)
    ppr (IEThingAbs  _   thing) = ppr (unLoc thing)
    ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]
    ppr (IEThingWith _ thing wc withs flds)
        = ppr (unLoc thing) <> parens (fsep (punctuate comma
                                              (ppWiths ++
                                              map (ppr . flLabel . unLoc) flds)))
      where
        ppWiths =
          case wc of
              NoIEWildcard ->
                map (ppr . unLoc) withs
              IEWildcard pos ->
                let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
                in bs ++ [text ".."] ++ as
    ppr (IEModuleContents _ mod')
        = text "module" <+> ppr mod'
    ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")
    ppr (IEDoc _ doc)             = ppr doc
    ppr (IEDocNamed _ string)     = text ("<IEDocNamed: " ++ string ++ ">")
    ppr (XIE x) = ppr x

instance (HasOccName name) => HasOccName (IEWrappedName name) where
  occName w = occName (ieWrappedName w)

instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where
  pprBndr bs   w = pprBndr bs   (ieWrappedName w)
  pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)
  pprInfixOcc  w = pprInfixOcc  (ieWrappedName w)

instance (OutputableBndr name) => Outputable (IEWrappedName name) where
  ppr (IEName    n) = pprPrefixOcc (unLoc n)
  ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)
  ppr (IEType    n) = text "type"    <+> pprPrefixOcc (unLoc n)

pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
    where
    occ = occName name
    type_pref | isTcOcc occ && isSymOcc occ = text "type"
              | otherwise                   = empty


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HsInstances where

-- This module defines the Data instances for the hsSyn AST.

-- It happens here to avoid massive constraint types on the AST with concomitant
-- slow GHC bootstrap times.

-- UndecidableInstances ?

import Data.Data hiding ( Fixity )

import GhcPrelude
import HsExtension
import HsBinds
import HsDecls
import HsExpr
import HsLit
import HsTypes
import HsPat
import HsImpExp

-- ---------------------------------------------------------------------
-- Data derivations from HsSyn -----------------------------------------

-- ---------------------------------------------------------------------
-- Data derivations from HsBinds ---------------------------------------

-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR)
deriving instance Data (HsLocalBindsLR GhcPs GhcPs)
deriving instance Data (HsLocalBindsLR GhcPs GhcRn)
deriving instance Data (HsLocalBindsLR GhcRn GhcRn)
deriving instance Data (HsLocalBindsLR GhcTc GhcTc)

-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR)
deriving instance Data (HsValBindsLR GhcPs GhcPs)
deriving instance Data (HsValBindsLR GhcPs GhcRn)
deriving instance Data (HsValBindsLR GhcRn GhcRn)
deriving instance Data (HsValBindsLR GhcTc GhcTc)

-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
deriving instance Data (NHsValBindsLR GhcPs)
deriving instance Data (NHsValBindsLR GhcRn)
deriving instance Data (NHsValBindsLR GhcTc)

-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
deriving instance Data (HsBindLR GhcPs GhcPs)
deriving instance Data (HsBindLR GhcPs GhcRn)
deriving instance Data (HsBindLR GhcRn GhcRn)
deriving instance Data (HsBindLR GhcTc GhcTc)

-- deriving instance (DataId p)       => Data (ABExport p)
deriving instance Data (ABExport GhcPs)
deriving instance Data (ABExport GhcRn)
deriving instance Data (ABExport GhcTc)

-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR)
deriving instance Data (PatSynBind GhcPs GhcPs)
deriving instance Data (PatSynBind GhcPs GhcRn)
deriving instance Data (PatSynBind GhcRn GhcRn)
deriving instance Data (PatSynBind GhcTc GhcTc)

-- deriving instance (DataIdLR p p)   => Data (HsIPBinds p)
deriving instance Data (HsIPBinds GhcPs)
deriving instance Data (HsIPBinds GhcRn)
deriving instance Data (HsIPBinds GhcTc)

-- deriving instance (DataIdLR p p)   => Data (IPBind p)
deriving instance Data (IPBind GhcPs)
deriving instance Data (IPBind GhcRn)
deriving instance Data (IPBind GhcTc)

-- deriving instance (DataIdLR p p)   => Data (Sig p)
deriving instance Data (Sig GhcPs)
deriving instance Data (Sig GhcRn)
deriving instance Data (Sig GhcTc)

-- deriving instance (DataId p)       => Data (FixitySig p)
deriving instance Data (FixitySig GhcPs)
deriving instance Data (FixitySig GhcRn)
deriving instance Data (FixitySig GhcTc)

-- deriving instance (DataIdLR p p)   => Data (HsPatSynDir p)
deriving instance Data (HsPatSynDir GhcPs)
deriving instance Data (HsPatSynDir GhcRn)
deriving instance Data (HsPatSynDir GhcTc)

-- ---------------------------------------------------------------------
-- Data derivations from HsDecls ---------------------------------------

-- deriving instance (DataIdLR p p) => Data (HsDecl p)
deriving instance Data (HsDecl GhcPs)
deriving instance Data (HsDecl GhcRn)
deriving instance Data (HsDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsGroup p)
deriving instance Data (HsGroup GhcPs)
deriving instance Data (HsGroup GhcRn)
deriving instance Data (HsGroup GhcTc)

-- deriving instance (DataIdLR p p) => Data (SpliceDecl p)
deriving instance Data (SpliceDecl GhcPs)
deriving instance Data (SpliceDecl GhcRn)
deriving instance Data (SpliceDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (TyClDecl p)
deriving instance Data (TyClDecl GhcPs)
deriving instance Data (TyClDecl GhcRn)
deriving instance Data (TyClDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
deriving instance Data (TyClGroup GhcPs)
deriving instance Data (TyClGroup GhcRn)
deriving instance Data (TyClGroup GhcTc)

-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p)
deriving instance Data (FamilyResultSig GhcPs)
deriving instance Data (FamilyResultSig GhcRn)
deriving instance Data (FamilyResultSig GhcTc)

-- deriving instance (DataIdLR p p) => Data (FamilyDecl p)
deriving instance Data (FamilyDecl GhcPs)
deriving instance Data (FamilyDecl GhcRn)
deriving instance Data (FamilyDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p)
deriving instance Data (InjectivityAnn GhcPs)
deriving instance Data (InjectivityAnn GhcRn)
deriving instance Data (InjectivityAnn GhcTc)

-- deriving instance (DataIdLR p p) => Data (FamilyInfo p)
deriving instance Data (FamilyInfo GhcPs)
deriving instance Data (FamilyInfo GhcRn)
deriving instance Data (FamilyInfo GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsDataDefn p)
deriving instance Data (HsDataDefn GhcPs)
deriving instance Data (HsDataDefn GhcRn)
deriving instance Data (HsDataDefn GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p)
deriving instance Data (HsDerivingClause GhcPs)
deriving instance Data (HsDerivingClause GhcRn)
deriving instance Data (HsDerivingClause GhcTc)

-- deriving instance (DataIdLR p p) => Data (ConDecl p)
deriving instance Data (ConDecl GhcPs)
deriving instance Data (ConDecl GhcRn)
deriving instance Data (ConDecl GhcTc)

-- deriving instance DataIdLR p p   => Data (TyFamInstDecl p)
deriving instance Data (TyFamInstDecl GhcPs)
deriving instance Data (TyFamInstDecl GhcRn)
deriving instance Data (TyFamInstDecl GhcTc)

-- deriving instance DataIdLR p p   => Data (DataFamInstDecl p)
deriving instance Data (DataFamInstDecl GhcPs)
deriving instance Data (DataFamInstDecl GhcRn)
deriving instance Data (DataFamInstDecl GhcTc)

-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs)
deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs)

-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p)
deriving instance Data (ClsInstDecl GhcPs)
deriving instance Data (ClsInstDecl GhcRn)
deriving instance Data (ClsInstDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (InstDecl p)
deriving instance Data (InstDecl GhcPs)
deriving instance Data (InstDecl GhcRn)
deriving instance Data (InstDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (DerivDecl p)
deriving instance Data (DerivDecl GhcPs)
deriving instance Data (DerivDecl GhcRn)
deriving instance Data (DerivDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (DerivStrategy p)
deriving instance Data (DerivStrategy GhcPs)
deriving instance Data (DerivStrategy GhcRn)
deriving instance Data (DerivStrategy GhcTc)

-- deriving instance (DataIdLR p p) => Data (DefaultDecl p)
deriving instance Data (DefaultDecl GhcPs)
deriving instance Data (DefaultDecl GhcRn)
deriving instance Data (DefaultDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (ForeignDecl p)
deriving instance Data (ForeignDecl GhcPs)
deriving instance Data (ForeignDecl GhcRn)
deriving instance Data (ForeignDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
deriving instance Data (RuleDecls GhcPs)
deriving instance Data (RuleDecls GhcRn)
deriving instance Data (RuleDecls GhcTc)

-- deriving instance (DataIdLR p p) => Data (RuleDecl p)
deriving instance Data (RuleDecl GhcPs)
deriving instance Data (RuleDecl GhcRn)
deriving instance Data (RuleDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (RuleBndr p)
deriving instance Data (RuleBndr GhcPs)
deriving instance Data (RuleBndr GhcRn)
deriving instance Data (RuleBndr GhcTc)

-- deriving instance (DataId p)     => Data (WarnDecls p)
deriving instance Data (WarnDecls GhcPs)
deriving instance Data (WarnDecls GhcRn)
deriving instance Data (WarnDecls GhcTc)

-- deriving instance (DataId p)     => Data (WarnDecl p)
deriving instance Data (WarnDecl GhcPs)
deriving instance Data (WarnDecl GhcRn)
deriving instance Data (WarnDecl GhcTc)

-- deriving instance (DataIdLR p p) => Data (AnnDecl p)
deriving instance Data (AnnDecl GhcPs)
deriving instance Data (AnnDecl GhcRn)
deriving instance Data (AnnDecl GhcTc)

-- deriving instance (DataId p)     => Data (RoleAnnotDecl p)
deriving instance Data (RoleAnnotDecl GhcPs)
deriving instance Data (RoleAnnotDecl GhcRn)
deriving instance Data (RoleAnnotDecl GhcTc)

-- ---------------------------------------------------------------------
-- Data derivations from HsExpr ----------------------------------------

-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
deriving instance Data (SyntaxExpr GhcPs)
deriving instance Data (SyntaxExpr GhcRn)
deriving instance Data (SyntaxExpr GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsExpr p)
deriving instance Data (HsExpr GhcPs)
deriving instance Data (HsExpr GhcRn)
deriving instance Data (HsExpr GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsTupArg p)
deriving instance Data (HsTupArg GhcPs)
deriving instance Data (HsTupArg GhcRn)
deriving instance Data (HsTupArg GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsCmd p)
deriving instance Data (HsCmd GhcPs)
deriving instance Data (HsCmd GhcRn)
deriving instance Data (HsCmd GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsCmdTop p)
deriving instance Data (HsCmdTop GhcPs)
deriving instance Data (HsCmdTop GhcRn)
deriving instance Data (HsCmdTop GhcTc)

-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
deriving instance (Data body) => Data (MatchGroup GhcPs body)
deriving instance (Data body) => Data (MatchGroup GhcRn body)
deriving instance (Data body) => Data (MatchGroup GhcTc body)

-- deriving instance (DataIdLR p p,Data body) => Data (Match      p body)
deriving instance (Data body) => Data (Match      GhcPs body)
deriving instance (Data body) => Data (Match      GhcRn body)
deriving instance (Data body) => Data (Match      GhcTc body)

-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs      p body)
deriving instance (Data body) => Data (GRHSs     GhcPs body)
deriving instance (Data body) => Data (GRHSs     GhcRn body)
deriving instance (Data body) => Data (GRHSs     GhcTc body)

-- deriving instance (DataIdLR p p,Data body) => Data (GRHS       p body)
deriving instance (Data body) => Data (GRHS     GhcPs body)
deriving instance (Data body) => Data (GRHS     GhcRn body)
deriving instance (Data body) => Data (GRHS     GhcTc body)

-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR   p p body)
deriving instance (Data body) => Data (StmtLR   GhcPs GhcPs body)
deriving instance (Data body) => Data (StmtLR   GhcPs GhcRn body)
deriving instance (Data body) => Data (StmtLR   GhcRn GhcRn body)
deriving instance (Data body) => Data (StmtLR   GhcTc GhcTc body)

deriving instance Data RecStmtTc

-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p)
deriving instance Data (ParStmtBlock GhcPs GhcPs)
deriving instance Data (ParStmtBlock GhcPs GhcRn)
deriving instance Data (ParStmtBlock GhcRn GhcRn)
deriving instance Data (ParStmtBlock GhcTc GhcTc)

-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p)
deriving instance Data (ApplicativeArg GhcPs)
deriving instance Data (ApplicativeArg GhcRn)
deriving instance Data (ApplicativeArg GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsSplice p)
deriving instance Data (HsSplice GhcPs)
deriving instance Data (HsSplice GhcRn)
deriving instance Data (HsSplice GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)
deriving instance Data (HsSplicedThing GhcPs)
deriving instance Data (HsSplicedThing GhcRn)
deriving instance Data (HsSplicedThing GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsBracket p)
deriving instance Data (HsBracket GhcPs)
deriving instance Data (HsBracket GhcRn)
deriving instance Data (HsBracket GhcTc)

-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
deriving instance Data (ArithSeqInfo GhcPs)
deriving instance Data (ArithSeqInfo GhcRn)
deriving instance Data (ArithSeqInfo GhcTc)

deriving instance                   Data RecordConTc
deriving instance                   Data CmdTopTc
deriving instance                   Data PendingRnSplice
deriving instance                   Data PendingTcSplice

-- ---------------------------------------------------------------------
-- Data derivations from HsLit ----------------------------------------

-- deriving instance (DataId p) => Data (HsLit p)
deriving instance Data (HsLit GhcPs)
deriving instance Data (HsLit GhcRn)
deriving instance Data (HsLit GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsOverLit p)
deriving instance Data (HsOverLit GhcPs)
deriving instance Data (HsOverLit GhcRn)
deriving instance Data (HsOverLit GhcTc)

-- ---------------------------------------------------------------------
-- Data derivations from HsPat -----------------------------------------

-- deriving instance (DataIdLR p p) => Data (Pat p)
deriving instance Data (Pat GhcPs)
deriving instance Data (Pat GhcRn)
deriving instance Data (Pat GhcTc)

deriving instance Data ListPatTc

-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)
deriving instance (Data body) => Data (HsRecFields GhcPs body)
deriving instance (Data body) => Data (HsRecFields GhcRn body)
deriving instance (Data body) => Data (HsRecFields GhcTc body)

-- ---------------------------------------------------------------------
-- Data derivations from HsTypes ---------------------------------------

-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p)
deriving instance Data (LHsQTyVars GhcPs)
deriving instance Data (LHsQTyVars GhcRn)
deriving instance Data (LHsQTyVars GhcTc)

-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)
deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)

-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)

-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
deriving instance Data (HsTyVarBndr GhcPs)
deriving instance Data (HsTyVarBndr GhcRn)
deriving instance Data (HsTyVarBndr GhcTc)

-- deriving instance (DataIdLR p p) => Data (HsType p)
deriving instance Data (HsType GhcPs)
deriving instance Data (HsType GhcRn)
deriving instance Data (HsType GhcTc)

deriving instance Data (LHsTypeArg GhcPs)
deriving instance Data (LHsTypeArg GhcRn)
deriving instance Data (LHsTypeArg GhcTc)

-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
deriving instance Data (ConDeclField GhcPs)
deriving instance Data (ConDeclField GhcRn)
deriving instance Data (ConDeclField GhcTc)

-- deriving instance (DataId p)     => Data (FieldOcc p)
deriving instance Data (FieldOcc GhcPs)
deriving instance Data (FieldOcc GhcRn)
deriving instance Data (FieldOcc GhcTc)

-- deriving instance DataId p       => Data (AmbiguousFieldOcc p)
deriving instance Data (AmbiguousFieldOcc GhcPs)
deriving instance Data (AmbiguousFieldOcc GhcRn)
deriving instance Data (AmbiguousFieldOcc GhcTc)

-- deriving instance (DataId name) => Data (ImportDecl name)
deriving instance Data (ImportDecl GhcPs)
deriving instance Data (ImportDecl GhcRn)
deriving instance Data (ImportDecl GhcTc)

-- deriving instance (DataId name)             => Data (IE name)
deriving instance Data (IE GhcPs)
deriving instance Data (IE GhcRn)
deriving instance Data (IE GhcTc)

-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name)
deriving instance Eq (IE GhcPs)
deriving instance Eq (IE GhcRn)
deriving instance Eq (IE GhcTc)

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


{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[HsLit]{Abstract syntax: source-language literals}
-}

{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}

module HsLit where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
                    negateFractionalLit,SourceText(..),pprWithSourceText )
import Type
import Outputable
import FastString
import HsExtension

import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )

{-
************************************************************************
*                                                                      *
\subsection[HsLit]{Literals}
*                                                                      *
************************************************************************
-}

-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
-- Note [Trees that grow] in HsExtension for the Xxxxx fields in the following
-- | Haskell Literal
data HsLit x
  = HsChar (XHsChar x) {- SourceText -} Char
      -- ^ Character
  | HsCharPrim (XHsCharPrim x) {- SourceText -} Char
      -- ^ Unboxed character
  | HsString (XHsString x) {- SourceText -} FastString
      -- ^ String
  | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString
      -- ^ Packed bytes
  | HsInt (XHsInt x)  IntegralLit
      -- ^ Genuinely an Int; arises from
      -- @TcGenDeriv@, and from TRANSLATION
  | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer
      -- ^ literal @Int#@
  | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer
      -- ^ literal @Word#@
  | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer
      -- ^ literal @Int64#@
  | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer
      -- ^ literal @Word64#@
  | HsInteger (XHsInteger x) {- SourceText -} Integer Type
      -- ^ Genuinely an integer; arises only
      -- from TRANSLATION (overloaded
      -- literals are done with HsOverLit)
  | HsRat (XHsRat x)  FractionalLit Type
      -- ^ Genuinely a rational; arises only from
      -- TRANSLATION (overloaded literals are
      -- done with HsOverLit)
  | HsFloatPrim (XHsFloatPrim x)   FractionalLit
      -- ^ Unboxed Float
  | HsDoublePrim (XHsDoublePrim x) FractionalLit
      -- ^ Unboxed Double

  | XLit (XXLit x)

type instance XHsChar       (GhcPass _) = SourceText
type instance XHsCharPrim   (GhcPass _) = SourceText
type instance XHsString     (GhcPass _) = SourceText
type instance XHsStringPrim (GhcPass _) = SourceText
type instance XHsInt        (GhcPass _) = NoExt
type instance XHsIntPrim    (GhcPass _) = SourceText
type instance XHsWordPrim   (GhcPass _) = SourceText
type instance XHsInt64Prim  (GhcPass _) = SourceText
type instance XHsWord64Prim (GhcPass _) = SourceText
type instance XHsInteger    (GhcPass _) = SourceText
type instance XHsRat        (GhcPass _) = NoExt
type instance XHsFloatPrim  (GhcPass _) = NoExt
type instance XHsDoublePrim (GhcPass _) = NoExt
type instance XXLit         (GhcPass _) = NoExt

instance Eq (HsLit x) where
  (HsChar _ x1)       == (HsChar _ x2)       = x1==x2
  (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2
  (HsString _ x1)     == (HsString _ x2)     = x1==x2
  (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2
  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2
  (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2
  (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2
  (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2
  (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2
  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2
  (HsRat _ x1 _)      == (HsRat _ x2 _)      = x1==x2
  (HsFloatPrim _ x1)  == (HsFloatPrim _ x2)  = x1==x2
  (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2
  _                   == _                   = False

-- | Haskell Overloaded Literal
data HsOverLit p
  = OverLit {
      ol_ext :: (XOverLit p),
      ol_val :: OverLitVal,
      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]

  | XOverLit
      (XXOverLit p)

data OverLitTc
  = OverLitTc {
        ol_rebindable :: Bool, -- Note [ol_rebindable]
        ol_type :: Type }
  deriving Data

type instance XOverLit GhcPs = NoExt
type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]
type instance XOverLit GhcTc = OverLitTc

type instance XXOverLit (GhcPass _) = NoExt

-- Note [Literal source text] in BasicTypes for SourceText fields in
-- the following
-- | Overloaded Literal Value
data OverLitVal
  = HsIntegral   !IntegralLit            -- ^ Integer-looking literals;
  | HsFractional !FractionalLit          -- ^ Frac-looking literals
  | HsIsString   !SourceText !FastString -- ^ String-looking literals
  deriving Data

negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"

overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit (OverLitTc _ ty) _ _) = ty
overLitType XOverLit{} = panic "overLitType"

-- | Convert a literal from one index type to another, updating the annotations
-- according to the relevant 'Convertable' instance
convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b
convertLit (HsChar a x)       = (HsChar (convert a) x)
convertLit (HsCharPrim a x)   = (HsCharPrim (convert a) x)
convertLit (HsString a x)     = (HsString (convert a) x)
convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x)
convertLit (HsInt a x)        = (HsInt (convert a) x)
convertLit (HsIntPrim a x)    = (HsIntPrim (convert a) x)
convertLit (HsWordPrim a x)   = (HsWordPrim (convert a) x)
convertLit (HsInt64Prim a x)  = (HsInt64Prim (convert a) x)
convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x)
convertLit (HsInteger a x b)  = (HsInteger (convert a) x b)
convertLit (HsRat a x b)      = (HsRat (convert a) x b)
convertLit (HsFloatPrim a x)  = (HsFloatPrim (convert a) x)
convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
convertLit (XLit a)           = (XLit (convert a))

{-
Note [ol_rebindable]
~~~~~~~~~~~~~~~~~~~~
The ol_rebindable field is True if this literal is actually
using rebindable syntax.  Specifically:

  False iff ol_witness is the standard one
  True  iff ol_witness is non-standard

Equivalently it's True if
  a) RebindableSyntax is on
  b) the witness for fromInteger/fromRational/fromString
     that happens to be in scope isn't the standard one

Note [Overloaded literal witnesses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Before* type checking, the HsExpr in an HsOverLit is the
name of the coercion function, 'fromInteger' or 'fromRational'.
*After* type checking, it is a witness for the literal, such as
        (fromInteger 3) or lit_78
This witness should replace the literal.

This dual role is unusual, because we're replacing 'fromInteger' with
a call to fromInteger.  Reason: it allows commoning up of the fromInteger
calls, which wouldn't be possible if the desugarer made the application.

The PostTcType in each branch records the type the overload literal is
found to have.
-}

-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2
  _ == _ = panic "Eq HsOverLit"

instance Eq OverLitVal where
  (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2
  (HsFractional f1)   == (HsFractional f2)   = f1 == f2
  (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2
  _                   == _                   = False

instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2
  compare _ _ = panic "Ord HsOverLit"

instance Ord OverLitVal where
  compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2
  compare (HsIntegral _)      (HsFractional _)    = LT
  compare (HsIntegral _)      (HsIsString _ _)    = LT
  compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2
  compare (HsFractional _)    (HsIntegral   _)    = GT
  compare (HsFractional _)    (HsIsString _ _)    = LT
  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `compare` s2
  compare (HsIsString _ _)    (HsIntegral   _)    = GT
  compare (HsIsString _ _)    (HsFractional _)    = GT

-- Instance specific to GhcPs, need the SourceText
instance p ~ GhcPass pass => Outputable (HsLit p) where
    ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)
    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)
    ppr (HsString st s)     = pprWithSourceText st (pprHsString s)
    ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
    ppr (HsInt _ i)
      = pprWithSourceText (il_text i) (integer (il_value i))
    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)
    ppr (HsRat _ f _)       = ppr f
    ppr (HsFloatPrim _ f)   = ppr f <> primFloatSuffix
    ppr (HsDoublePrim _ d)  = ppr d <> primDoubleSuffix
    ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)
    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)
    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)
    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
    ppr (XLit x) = ppr x

pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText         _ doc = doc
pp_st_suffix (SourceText st) suffix _   = text st <> suffix

-- in debug mode, print the expression that it's resolved to, too
instance (p ~ GhcPass pass, OutputableBndrId p)
       => Outputable (HsOverLit p) where
  ppr (OverLit {ol_val=val, ol_witness=witness})
        = ppr val <+> (whenPprDebug (parens (pprExpr witness)))
  ppr (XOverLit x) = ppr x

instance Outputable OverLitVal where
  ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))
  ppr (HsFractional f)   = ppr f
  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)

-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
-- match warnings. All are printed the same (i.e., without hashes if they are
-- primitive and not wrapped in constructors if they are boxed). This happens
-- mainly for too reasons:
--  * We do not want to expose their internal representation
--  * The warnings become too messy
pmPprHsLit :: HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c)       = pprHsChar c
pmPprHsLit (HsCharPrim _ c)   = pprHsChar c
pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i)        = integer (il_value i)
pmPprHsLit (HsIntPrim _ i)    = integer i
pmPprHsLit (HsWordPrim _ w)   = integer w
pmPprHsLit (HsInt64Prim _ i)  = integer i
pmPprHsLit (HsWord64Prim _ w) = integer w
pmPprHsLit (HsInteger _ i _)  = integer i
pmPprHsLit (HsRat _ f _)      = ppr f
pmPprHsLit (HsFloatPrim _ f)  = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
pmPprHsLit (XLit x)           = ppr x

-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
-- to be parenthesized under precedence @p@.
hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
hsLitNeedsParens p = go
  where
    go (HsChar {})        = False
    go (HsCharPrim {})    = False
    go (HsString {})      = False
    go (HsStringPrim {})  = False
    go (HsInt _ x)        = p > topPrec && il_neg x
    go (HsIntPrim _ x)    = p > topPrec && x < 0
    go (HsWordPrim {})    = False
    go (HsInt64Prim _ x)  = p > topPrec && x < 0
    go (HsWord64Prim {})  = False
    go (HsInteger _ x _)  = p > topPrec && x < 0
    go (HsRat _ x _)      = p > topPrec && fl_neg x
    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x
    go (HsDoublePrim _ x) = p > topPrec && fl_neg x
    go (XLit _)           = False

-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
-- @ol@ needs to be parenthesized under precedence @p@.
hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
  where
    go :: OverLitVal -> Bool
    go (HsIntegral x)   = p > topPrec && il_neg x
    go (HsFractional x) = p > topPrec && fl_neg x
    go (HsIsString {})  = False
hsOverLitNeedsParens _ (XOverLit { }) = False