-- Copyright 2020-2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- | A GHC plugin making numeric literals and patterns pseudo-dependently-typed.

module DependentLiterals.Plugin (plugin) where

import Data.Foldable (for_)
import Data.Maybe (fromMaybe, isJust)

import qualified Data.Generics as SYB

-- GHC has been overhauling its module hierarchy, but to a significant extent,
-- it's renaming modules entirely and not regrouping exports; most of these we
-- paper over by defining macros for their most-up-to-date name with
-- underscores instead of dots.

-- This one was renamed twice in the range of supported versions.
#if MIN_VERSION_ghc(9,0,0)
#define GHC_Hs_Type GHC.Hs.Type
#elif MIN_VERSION_ghc(8,10,0)
#define GHC_Hs_Type GHC.Hs.Types
#else
#define GHC_Hs_Type HsTypes
#endif

-- This one was double-renamed, too.  Who knows how I managed to call the macro
-- GHC_Types_SourceText before any released versions actually called it that.
-- Maybe I was looking at the source on GitHub?
#if MIN_VERSION_ghc(9,2,0)
#define GHC_Types_SourceText GHC.Types.SourceText
#elif MIN_VERSION_ghc(9,0,0)
#define GHC_Types_SourceText GHC.Types.Basic
#else
#define GHC_Types_SourceText BasicTypes
#endif

-- Renames from 9.0 to 9.2
#if MIN_VERSION_ghc(9,2,0)
#define Language_Haskell_Syntax_Extension Language.Haskell.Syntax.Extension
#else
#define Language_Haskell_Syntax_Extension GHC.Hs.Extension
#endif

-- Renames from 8.10 to 9.0
#if MIN_VERSION_ghc(9,0,0)
#define GHC_Plugins GHC.Plugins
#define GHC_Types_Basic GHC.Types.Basic
#define GHC_Types_Name_Occurrence GHC.Types.Name.Occurrence
#define GHC_Types_Name_Reader GHC.Types.Name.Reader
#define GHC_Unit_Module_Name GHC.Unit.Module.Name
#define GHC_Utils_Outputable GHC.Utils.Outputable
#else
#define GHC_Plugins GhcPlugins
#define GHC_Types_Basic BasicTypes
#define GHC_Types_Name_Occurrence OccName
#define GHC_Types_Name_Reader RdrName
#define GHC_Unit_Module_Name Module
#define GHC_Utils_Outputable Outputable
#endif

-- Renames from 8.8 to 8.10
#if MIN_VERSION_ghc(8,10,0)
#define GHC_Hs GHC.Hs
#define GHC_Hs_Expr GHC.Hs.Expr
#define GHC_Hs_Extension GHC.Hs.Extension
#define GHC_Hs_Lit GHC.Hs.Lit
#define GHC_Hs_Pat GHC.Hs.Pat
#define GHC_Hs_Utils GHC.Hs.Utils
#else
#define GHC_Hs HsSyn
#define GHC_Hs_Expr HsExpr
#define GHC_Hs_Extension HsExtension
#define GHC_Hs_Lit HsLit
#define GHC_Hs_Pat HsPat
#define GHC_Hs_Utils HsUtils
#endif

import GHC_Hs
         ( HsModule(..), HsWildCardBndrs(HsWC)
         , HsTyLit(HsNumTy)
         , ImportDecl(..), IEWrappedName(..), IE(..)
         )
import GHC_Hs_Lit (HsOverLit(..), OverLitVal(HsIntegral))
import GHC_Hs_Expr (HsExpr(HsAppType, HsOverLit, HsApp, NegApp), LHsExpr)
import GHC_Hs_Extension (GhcPs, GhcPass)
import GHC_Hs_Type
         ( HsType(HsAppTy, HsParTy, HsTyLit, HsTyVar)
         , LHsType, HsConDetails(PrefixCon)
         )
import GHC_Hs_Pat (LPat, Pat(NPat, ViewPat))
import GHC_Hs_Utils (nlHsVar, nlHsApp)
import GHC_Plugins
         ( Hsc
         , Plugin(parsedResultAction, pluginRecompile), defaultPlugin
         , PluginRecompile(NoForceRecompile)
         , CommandLineOption
         , DynFlags, Located, GenLocated(L), noSrcSpan
         , getDynFlags, liftIO
         , gopt_set, GeneralFlag(Opt_SuppressModulePrefixes)
         , SrcSpan
         )
import GHC_Types_Name_Occurrence (OccName, mkTcOcc, mkVarOcc, mkDataOcc)
import GHC_Types_Name_Reader (RdrName, mkRdrQual, mkRdrUnqual)
import GHC_Types_SourceText (IntegralLit(IL), SourceText(NoSourceText))
import GHC_Unit_Module_Name (ModuleName, mkModuleName)
import GHC_Utils_Outputable ((<+>), Outputable, nest, ppr, sep, text)

-- For semantic changes, we generally try to paper over them by adding
-- compatibility shims, e.g. pattern synonyms, to make the code below look like
-- it's targeting the most-up-to-date version.

#if MIN_VERSION_ghc(9,2,0)
import GHC_Hs (HsParsedModule(..))
import GHC.Driver.Ppr (showSDoc)
import GHC.Parser.Annotation
         ( SrcAnn, SrcSpanAnn'(..), SrcSpanAnnA
         , EpAnn(EpAnnNotUsed), EpaLocation(EpaDelta)
         , DeltaPos(SameLine), LocatedN
         , noSrcSpanA, noLocA
         )
#else
import GHC_Plugins (HsParsedModule(..))
import GHC_Utils_Outputable (showSDoc)
#endif

#if MIN_VERSION_ghc(8,10,0) && !MIN_VERSION_ghc(9,2,0)
import GHC_Plugins (noLoc)
#endif

#if MIN_VERSION_ghc(9,0,0)
import GHC_Hs_Pat (Pat(ConPat))
import GHC.Unit.Types (IsBootInterface(..))
#else
-- Imports for pre-9.0 compatibily shims.
import GHC_Hs_Pat (Pat(ConPatIn), HsConPatDetails)
import GHC_Hs_Extension (IdP)
#endif

#if MIN_VERSION_ghc(8,10,0)
import GHC.Hs.ImpExp (ImportDeclQualifiedStyle(..))
import Language_Haskell_Syntax_Extension (NoExtField(..))
#else
-- Imports for pre-8.10 compatibily shims.
import HsExtension (NoExt(..))
#endif

#if MIN_VERSION_ghc(8,8,0)
import GHC_Types_Basic (PromotionFlag(..))
#else
-- Imports for pre-8.8 compatibily shims.
import GHC_Plugins (noLoc)
import HsTypes (Promoted(..))
#endif

-- Pre-9.2 compatibility shims.
#if !MIN_VERSION_ghc(9,2,0)
nl :: a -> Located a
nl :: a -> Located a
nl = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan

ieType :: Located name -> IEWrappedName name
ieType :: Located name -> IEWrappedName name
ieType = Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEType

type EpAnn = NoExtField

pattern EpAnnNotUsed :: EpAnn
pattern $bEpAnnNotUsed :: EpAnn
$mEpAnnNotUsed :: forall r. EpAnn -> (Void# -> r) -> (Void# -> r) -> r
EpAnnNotUsed = NoExtField

type SrcSpanAnnA = SrcSpan
toSrcSpanAnnA :: SrcSpan -> SrcSpan
toSrcSpanAnnA :: SrcSpan -> SrcSpan
toSrcSpanAnnA = SrcSpan -> SrcSpan
forall a. a -> a
id

mkPrefixCon :: [arg] -> HsConDetails arg rec
mkPrefixCon :: [arg] -> HsConDetails arg rec
mkPrefixCon = [arg] -> HsConDetails arg rec
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon
#else
nl :: a -> GenLocated (SrcAnn ann) a
nl = L noSrcSpanA

ieType :: LocatedN name -> IEWrappedName name
ieType = IEType (EpaDelta (SameLine 1) [])

toSrcSpanAnnA :: SrcSpan -> SrcSpanAnnA
toSrcSpanAnnA l = SrcSpanAnn EpAnnNotUsed l

mkPrefixCon :: [arg] -> HsConDetails tyarg arg rec
mkPrefixCon = PrefixCon []
#endif


-- Pre-9.0 compatibility shims.
#if !MIN_VERSION_ghc(9,0,0)
pattern ConPat :: a -> Located (IdP p) -> HsConPatDetails p -> Pat p
pattern $bConPat :: a -> Located (IdP p) -> HsConPatDetails p -> Pat p
$mConPat :: forall r p.
Pat p
-> (forall a. a -> Located (IdP p) -> HsConPatDetails p -> r)
-> (Void# -> r)
-> r
ConPat ext con args <- (((,) NoExtField) -> (ext, ConPatIn con args))
 where
  ConPat a
_ext Located (IdP p)
con HsConPatDetails p
args = Located (IdP p) -> HsConPatDetails p -> Pat p
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP p)
con HsConPatDetails p
args

type HsModulePs = HsModule GhcPs

pattern NotBoot :: Bool
pattern $bNotBoot :: Bool
$mNotBoot :: forall r. Bool -> (Void# -> r) -> (Void# -> r) -> r
NotBoot = False
#else
type HsModulePs = HsModule
#endif

-- Pre-8.10 compatibility shims.
#if !MIN_VERSION_ghc(8,10,0)
type NoExtField = NoExt
pattern NoExtField :: NoExtField
pattern NoExtField = NoExt

type ImportDeclQualifiedStyle = Bool
pattern QualifiedPre, NotQualified :: ImportDeclQualifiedStyle
pattern QualifiedPre = True
pattern NotQualified = False
#endif

-- Pre-8.8 compatibility shims.
#if !MIN_VERSION_ghc(8,8,0)
type PromotionFlag = Promoted
pattern IsPromoted :: PromotionFlag
pattern IsPromoted = Promoted
#endif

data Config = Config
  { Config -> Bool
_cDoLiterals :: Bool
  , Config -> Bool
_cDoPatterns :: Bool
  , Config -> Bool
_cTraceThings :: Bool
  }

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Bool -> Bool -> Bool -> Config
Config Bool
True Bool
True Bool
False

interpretOpts :: [CommandLineOption] -> Config
interpretOpts :: [CommandLineOption] -> Config
interpretOpts [CommandLineOption]
opts0 = [CommandLineOption] -> Config -> Config
go [CommandLineOption]
opts0 Config
defaultConfig
 where
  go :: [CommandLineOption] -> Config -> Config
go [] Config
c = Config
c
  go (CommandLineOption
"nolits":[CommandLineOption]
opts) Config
c = [CommandLineOption] -> Config -> Config
go [CommandLineOption]
opts Config
c { _cDoLiterals :: Bool
_cDoLiterals = Bool
False }
  go (CommandLineOption
"nopats":[CommandLineOption]
opts) Config
c = [CommandLineOption] -> Config -> Config
go [CommandLineOption]
opts Config
c { _cDoPatterns :: Bool
_cDoPatterns = Bool
False }
  go (CommandLineOption
"trace":[CommandLineOption]
opts) Config
c = [CommandLineOption] -> Config -> Config
go [CommandLineOption]
opts Config
c { _cTraceThings :: Bool
_cTraceThings = Bool
True }
  go (CommandLineOption
opt:[CommandLineOption]
_) Config
_ = CommandLineOption -> Config
forall a. HasCallStack => CommandLineOption -> a
error (CommandLineOption -> Config) -> CommandLineOption -> Config
forall a b. (a -> b) -> a -> b
$
    CommandLineOption
"Illegal option " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show CommandLineOption
opt CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++
    CommandLineOption
".\nAll options: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ [CommandLineOption] -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show [CommandLineOption]
opts0

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
  { parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = \[CommandLineOption]
opts ModSummary
_ -> Config -> HsParsedModule -> Hsc HsParsedModule
parsedResultPlugin ([CommandLineOption] -> Config
interpretOpts [CommandLineOption]
opts)
  , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = \[CommandLineOption]
_ -> PluginRecompile -> IO PluginRecompile
forall (m :: * -> *) a. Monad m => a -> m a
return PluginRecompile
NoForceRecompile
  }

parsedResultPlugin :: Config -> HsParsedModule -> Hsc HsParsedModule
parsedResultPlugin :: Config -> HsParsedModule -> Hsc HsParsedModule
parsedResultPlugin Config
cfg HsParsedModule
m = do
  DynFlags
df <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Located HsModulePs
hpm_module' <- Config
-> DynFlags -> Located HsModulePs -> Hsc (Located HsModulePs)
transformParsed Config
cfg DynFlags
df (HsParsedModule -> Located HsModulePs
hpm_module HsParsedModule
m)
  HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ HsParsedModule
m { hpm_module :: Located HsModulePs
hpm_module = Located HsModulePs
hpm_module' }

when_ :: Applicative f => Bool -> (a -> f a) -> a -> f a
when_ :: Bool -> (a -> f a) -> a -> f a
when_ Bool
True a -> f a
f = a -> f a
f
when_ Bool
False a -> f a
_ = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

pattern LPat :: Pat (GhcPass p) -> LPat (GhcPass p)
#if !MIN_VERSION_ghc(8,8,0) || MIN_VERSION_ghc(8,10,0)
pattern $mLPat :: forall r (p :: Pass).
LPat (GhcPass p) -> (Pat (GhcPass p) -> r) -> (Void# -> r) -> r
LPat pat <- L _ pat
#else
pattern LPat pat <- pat
#endif

nlPat :: Pat (GhcPass p) -> LPat (GhcPass p)
nlPat :: Pat (GhcPass p) -> LPat (GhcPass p)
nlPat = Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p))
forall a. a -> a
id
#if MIN_VERSION_ghc(9,2,0)
  . noLocA
#elif !MIN_VERSION_ghc(8,8,0) || MIN_VERSION_ghc(8,10,0)
  (Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p)))
-> (Pat (GhcPass p) -> Located (Pat (GhcPass p)))
-> Pat (GhcPass p)
-> Located (Pat (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat (GhcPass p) -> Located (Pat (GhcPass p))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
#endif

transformParsed
  :: Config
  -> DynFlags
  -> Located HsModulePs
  -> Hsc (Located HsModulePs)
transformParsed :: Config
-> DynFlags -> Located HsModulePs -> Hsc (Located HsModulePs)
transformParsed Config{Bool
_cTraceThings :: Bool
_cDoPatterns :: Bool
_cDoLiterals :: Bool
_cTraceThings :: Config -> Bool
_cDoPatterns :: Config -> Bool
_cDoLiterals :: Config -> Bool
..} DynFlags
df' (L SrcSpan
modLoc HsModule{[LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (Located [LIE GhcPs])
Maybe LHsDocString
Maybe (Located WarningTxt)
Maybe (Located ModuleName)
hsmodName :: forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodExports :: forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodImports :: forall pass. HsModule pass -> [LImportDecl pass]
hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDeprecMessage :: forall pass. HsModule pass -> Maybe (Located WarningTxt)
hsmodHaddockModHeader :: forall pass. HsModule pass -> Maybe LHsDocString
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodDeprecMessage :: Maybe (Located WarningTxt)
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodName :: Maybe (Located ModuleName)
..}) = do
  [LHsDecl GhcPs]
decls <-
    [LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsDecl GhcPs]
hsmodDecls
      Hsc [LHsDecl GhcPs]
-> ([LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs]) -> Hsc [LHsDecl GhcPs]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool
-> ([LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs])
-> [LHsDecl GhcPs]
-> Hsc [LHsDecl GhcPs]
forall (f :: * -> *) a.
Applicative f =>
Bool -> (a -> f a) -> a -> f a
when_ Bool
_cDoLiterals
            ( GenericM Hsc -> GenericM Hsc
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((LHsExpr GhcPs -> Hsc (LHsExpr GhcPs)) -> a -> Hsc a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM (CommandLineOption
-> (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs
-> Hsc (LHsExpr GhcPs)
forall a.
Outputable a =>
CommandLineOption -> (a -> Maybe a) -> a -> Hsc a
wrapDebug CommandLineOption
"expression" LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
transformExp))
            ([LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs])
-> ([LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> [LHsDecl GhcPs]
-> Hsc [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Data a => a -> a) -> forall a. Data a => a -> a
SYB.everywhere ((LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
SYB.mkT LHsExpr GhcPs -> LHsExpr GhcPs
foldNegation)
            )
      Hsc [LHsDecl GhcPs]
-> ([LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs]) -> Hsc [LHsDecl GhcPs]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool
-> ([LHsDecl GhcPs] -> Hsc [LHsDecl GhcPs])
-> [LHsDecl GhcPs]
-> Hsc [LHsDecl GhcPs]
forall (f :: * -> *) a.
Applicative f =>
Bool -> (a -> f a) -> a -> f a
when_ Bool
_cDoPatterns
            (GenericM Hsc -> GenericM Hsc
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((Located (Pat GhcPs) -> Hsc (Located (Pat GhcPs))) -> a -> Hsc a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM (CommandLineOption
-> (Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs)))
-> Located (Pat GhcPs)
-> Hsc (Located (Pat GhcPs))
forall a.
Outputable a =>
CommandLineOption -> (a -> Maybe a) -> a -> Hsc a
wrapDebug CommandLineOption
"pattern" LPat GhcPs -> Maybe (LPat GhcPs)
Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs))
transformPat)))

  Located HsModulePs -> Hsc (Located HsModulePs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located HsModulePs -> Hsc (Located HsModulePs))
-> Located HsModulePs -> Hsc (Located HsModulePs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsModulePs -> Located HsModulePs
forall l e. l -> e -> GenLocated l e
L SrcSpan
modLoc (HsModulePs -> Located HsModulePs)
-> HsModulePs -> Located HsModulePs
forall a b. (a -> b) -> a -> b
$ HsModule :: forall pass.
Maybe (Located ModuleName)
-> Maybe (Located [LIE pass])
-> [LImportDecl pass]
-> [LHsDecl pass]
-> Maybe (Located WarningTxt)
-> Maybe LHsDocString
-> HsModule pass
HsModule
    { hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
decls
    , hsmodImports :: [LImportDecl GhcPs]
hsmodImports =
        ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE GhcPs]
-> LImportDecl GhcPs
forall pass.
(XCImportDecl pass ~ EpAnn) =>
ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE pass]
-> Located (ImportDecl pass)
mkModImport ModuleName
litMod Maybe (Located ModuleName)
forall a. Maybe a
Nothing ImportDeclQualifiedStyle
QualifiedPre Maybe [IE GhcPs]
forall a. Maybe a
Nothing LImportDecl GhcPs -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. a -> [a] -> [a]
:
        LImportDecl GhcPs
unqualLitModImport LImportDecl GhcPs -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. a -> [a] -> [a]
:
        LImportDecl GhcPs
qualIntModImport LImportDecl GhcPs -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. a -> [a] -> [a]
:
        [LImportDecl GhcPs]
hsmodImports
    , Maybe (Located [LIE GhcPs])
Maybe LHsDocString
Maybe (Located WarningTxt)
Maybe (Located ModuleName)
hsmodName :: Maybe (Located ModuleName)
hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodDeprecMessage :: Maybe (Located WarningTxt)
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodDeprecMessage :: Maybe (Located WarningTxt)
hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodName :: Maybe (Located ModuleName)
..
    }
 where
  df :: DynFlags
df = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
df' GeneralFlag
Opt_SuppressModulePrefixes

  litMod, intMod :: ModuleName
  litMod :: ModuleName
litMod = CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"DependentLiterals.Int"
  intMod :: ModuleName
intMod = CommandLineOption -> ModuleName
mkModuleName CommandLineOption
"Kinds.Integer"

  -- import qualified DependentLiterals.Int
  mkModImport :: ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE pass]
-> Located (ImportDecl pass)
mkModImport ModuleName
nm Maybe (Located ModuleName)
as ImportDeclQualifiedStyle
q Maybe [IE pass]
imports = ImportDecl pass -> Located (ImportDecl pass)
forall a. a -> Located a
nl (ImportDecl pass -> Located (ImportDecl pass))
-> ImportDecl pass -> Located (ImportDecl pass)
forall a b. (a -> b) -> a -> b
$ XCImportDecl pass
-> SourceText
-> Located ModuleName
-> Maybe StringLiteral
-> Bool
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (Located ModuleName)
-> Maybe (Bool, Located [LIE pass])
-> ImportDecl pass
forall pass.
XCImportDecl pass
-> SourceText
-> Located ModuleName
-> Maybe StringLiteral
-> Bool
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (Located ModuleName)
-> Maybe (Bool, Located [LIE pass])
-> ImportDecl pass
ImportDecl
    EpAnn
XCImportDecl pass
EpAnnNotUsed
    SourceText
NoSourceText
    (ModuleName -> Located ModuleName
forall a. a -> Located a
nl ModuleName
nm)
    Maybe StringLiteral
forall a. Maybe a
Nothing -- no package qualifier
    Bool
NotBoot
    Bool
False -- not marked safe
    ImportDeclQualifiedStyle
q -- qualified
    Bool
True -- implicit
    Maybe (Located ModuleName)
as -- "as" rename
    ((Bool
False,) (Located [LIE pass] -> (Bool, Located [LIE pass]))
-> ([IE pass] -> Located [LIE pass])
-> [IE pass]
-> (Bool, Located [LIE pass])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LIE pass] -> Located [LIE pass]
forall a. a -> Located a
nl ([LIE pass] -> Located [LIE pass])
-> ([IE pass] -> [LIE pass]) -> [IE pass] -> Located [LIE pass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IE pass -> LIE pass) -> [IE pass] -> [LIE pass]
forall a b. (a -> b) -> [a] -> [b]
map IE pass -> LIE pass
forall a. a -> Located a
nl ([IE pass] -> (Bool, Located [LIE pass]))
-> Maybe [IE pass] -> Maybe (Bool, Located [LIE pass])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [IE pass]
imports) -- no "hiding"

  -- Import a few things unqualified implicitly.  This way, when they appear in
  -- error messages, they won't have bulky module names attached.  All of these
  -- have -XMagicHash names so that they can't conflict with the subset of the
  -- namespace used by reasonable Haskell programmers, and most people can't
  -- ever tell that they're imported.
  -- TODO can we move this plugin post-renamer and do this by generating names
  -- that claim to have been originally unqualified?
  importVar :: IdP GhcPs -> IE GhcPs
importVar = XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar EpAnn
XIEVar GhcPs
NoExtField (LIEWrappedName (IdP GhcPs) -> IE GhcPs)
-> (IdP GhcPs -> LIEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs)
forall a. a -> Located a
nl (IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> IEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> LIEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs)
forall name. Located name -> IEWrappedName name
IEName (Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> Located (IdP GhcPs))
-> IdP GhcPs
-> IEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.IdP GhcPs -> Located (IdP GhcPs)
forall a. a -> Located a
nl
  importAll :: IdP GhcPs -> IE GhcPs
importAll = XIEThingAll GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAll pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAll EpAnn
XIEThingAll GhcPs
EpAnnNotUsed (LIEWrappedName (IdP GhcPs) -> IE GhcPs)
-> (IdP GhcPs -> LIEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs)
forall a. a -> Located a
nl (IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> IEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> LIEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs)
forall name. Located name -> IEWrappedName name
IEName (Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> Located (IdP GhcPs))
-> IdP GhcPs
-> IEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdP GhcPs -> Located (IdP GhcPs)
forall a. a -> Located a
nl
  importTyOp :: IdP GhcPs -> IE GhcPs
importTyOp = XIEThingAbs GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAbs pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAbs EpAnn
XIEThingAbs GhcPs
EpAnnNotUsed (LIEWrappedName (IdP GhcPs) -> IE GhcPs)
-> (IdP GhcPs -> LIEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> IE GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs)
forall a. a -> Located a
nl (IEWrappedName (IdP GhcPs) -> LIEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> IEWrappedName (IdP GhcPs))
-> IdP GhcPs
-> LIEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs)
forall name. Located name -> IEWrappedName name
ieType (Located (IdP GhcPs) -> IEWrappedName (IdP GhcPs))
-> (IdP GhcPs -> Located (IdP GhcPs))
-> IdP GhcPs
-> IEWrappedName (IdP GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdP GhcPs -> Located (IdP GhcPs)
forall a. a -> Located a
nl
  unqualLitModImport :: LImportDecl GhcPs
unqualLitModImport = ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE GhcPs]
-> LImportDecl GhcPs
forall pass.
(XCImportDecl pass ~ EpAnn) =>
ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE pass]
-> Located (ImportDecl pass)
mkModImport ModuleName
litMod Maybe (Located ModuleName)
forall a. Maybe a
Nothing ImportDeclQualifiedStyle
NotQualified (Maybe [IE GhcPs] -> LImportDecl GhcPs)
-> Maybe [IE GhcPs] -> LImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ [IE GhcPs] -> Maybe [IE GhcPs]
forall a. a -> Maybe a
Just
    [ IdP GhcPs -> IE GhcPs
importVar IdP GhcPs
RdrName
litHashName
    , IdP GhcPs -> IE GhcPs
importTyOp IdP GhcPs
RdrName
minusHashName
    ]
  qualIntModImport :: LImportDecl GhcPs
qualIntModImport = ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE GhcPs]
-> LImportDecl GhcPs
forall pass.
(XCImportDecl pass ~ EpAnn) =>
ModuleName
-> Maybe (Located ModuleName)
-> ImportDeclQualifiedStyle
-> Maybe [IE pass]
-> Located (ImportDecl pass)
mkModImport ModuleName
intMod Maybe (Located ModuleName)
forall a. Maybe a
Nothing ImportDeclQualifiedStyle
QualifiedPre (Maybe [IE GhcPs] -> LImportDecl GhcPs)
-> Maybe [IE GhcPs] -> LImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ [IE GhcPs] -> Maybe [IE GhcPs]
forall a. a -> Maybe a
Just
    [ IdP GhcPs -> IE GhcPs
importAll IdP GhcPs
RdrName
integerName
    ]

  qual :: OccName -> RdrName
  qual :: OccName -> RdrName
qual = ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
litMod

  integerName :: RdrName
integerName   = OccName -> RdrName
mkRdrUnqual (CommandLineOption -> OccName
mkTcOcc CommandLineOption
"Integer")
  minusHashName :: RdrName
minusHashName = OccName -> RdrName
mkRdrUnqual (CommandLineOption -> OccName
mkTcOcc CommandLineOption
"-#")
  negName :: RdrName
negName       = ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
intMod (CommandLineOption -> OccName
mkDataOcc CommandLineOption
"Neg")
  posName :: RdrName
posName       = ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
intMod (CommandLineOption -> OccName
mkDataOcc CommandLineOption
"Pos")
  cjustConName :: RdrName
cjustConName  = OccName -> RdrName
qual (CommandLineOption -> OccName
mkDataOcc CommandLineOption
"CJust")
  litHashName :: RdrName
litHashName   = OccName -> RdrName
mkRdrUnqual (CommandLineOption -> OccName
mkVarOcc CommandLineOption
"lit#")
  matchHashName :: RdrName
matchHashName = OccName -> RdrName
qual (CommandLineOption -> OccName
mkVarOcc CommandLineOption
"match#")

  infixl 4 `mkHsAppType`
  mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs
  mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs
mkHsAppType LHsExpr GhcPs
expr LHsType GhcPs
ty = XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType
#if MIN_VERSION_ghc(8,8,0)
#if MIN_VERSION_ghc(9,2,0)
    noSrcSpan
#else
    EpAnn
XAppTypeE GhcPs
NoExtField
#endif
    LHsExpr GhcPs
expr
    (XHsWC GhcPs (LHsType GhcPs)
-> LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsType GhcPs)
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC EpAnn
XHsWC GhcPs (LHsType GhcPs)
NoExtField LHsType GhcPs
ty)
#else
    (HsWC NoExtField ty)
    expr
#endif

  infixl 4 `nlHsAppType`
  nlHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
  nlHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
nlHsAppType LHsExpr GhcPs
expr LHsType GhcPs
ty = HsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> Located a
nl (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs
mkHsAppType LHsExpr GhcPs
expr LHsType GhcPs
ty

  infixl 4 `nlHsApp_`
  nlHsApp_ :: LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp_ = LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp

  litToTyLit :: IntegralLit -> LHsType GhcPs
  litToTyLit :: IntegralLit -> LHsType GhcPs
litToTyLit (IL SourceText
txt Bool
neg Integer
val) =
    HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
nl (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy EpAnn
XParTy GhcPs
EpAnnNotUsed (LHsType GhcPs -> HsType GhcPs) -> LHsType GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$
    HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
nl (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy EpAnn
XAppTy GhcPs
NoExtField
      (HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
nl (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar EpAnn
XTyVar GhcPs
EpAnnNotUsed PromotionFlag
IsPromoted (Located (IdP GhcPs) -> HsType GhcPs)
-> Located (IdP GhcPs) -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$
        RdrName -> Located RdrName
forall a. a -> Located a
nl (if Bool
neg then RdrName
negName else RdrName
posName))
      (HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
nl (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XTyLit GhcPs -> HsTyLit -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit EpAnn
XTyLit GhcPs
NoExtField (SourceText -> Integer -> HsTyLit
HsNumTy SourceText
txt (Integer -> Integer
forall a. Num a => a -> a
abs Integer
val)))

  debug :: String -> Hsc ()
  debug :: CommandLineOption -> Hsc ()
debug CommandLineOption
s
    | Bool
_cTraceThings = IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CommandLineOption -> IO ()
putStrLn CommandLineOption
s)
    | Bool
otherwise = () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  wrapDebug :: Outputable a => String -> (a -> Maybe a) -> a -> Hsc a
  wrapDebug :: CommandLineOption -> (a -> Maybe a) -> a -> Hsc a
wrapDebug CommandLineOption
thing a -> Maybe a
f a
x = do
    let r :: Maybe a
r = a -> Maybe a
f a
x
    Maybe a -> (a -> Hsc ()) -> Hsc ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe a
r (\a
x' ->
      CommandLineOption -> Hsc ()
debug (CommandLineOption -> Hsc ()) -> CommandLineOption -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> CommandLineOption
showSDoc DynFlags
df (SDoc -> CommandLineOption) -> SDoc -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
        [ CommandLineOption -> SDoc
text CommandLineOption
"Rewrote" SDoc -> SDoc -> SDoc
<+> CommandLineOption -> SDoc
text CommandLineOption
thing SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x SDoc -> SDoc -> SDoc
<+> CommandLineOption -> SDoc
text CommandLineOption
"to"
        , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x'
        ])
    a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Hsc a) -> a -> Hsc a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x Maybe a
r

  extractLit :: HsExpr GhcPs -> Maybe (IntegralLit, HsExpr GhcPs)
  extractLit :: HsExpr GhcPs -> Maybe (IntegralLit, HsExpr GhcPs)
extractLit (HsOverLit XOverLitE GhcPs
_ (OverLit XOverLit GhcPs
_ (HsIntegral IntegralLit
il) HsExpr GhcPs
w)) = (IntegralLit, HsExpr GhcPs) -> Maybe (IntegralLit, HsExpr GhcPs)
forall a. a -> Maybe a
Just (IntegralLit
il, HsExpr GhcPs
w)
  extractLit HsExpr GhcPs
_ = Maybe (IntegralLit, HsExpr GhcPs)
forall a. Maybe a
Nothing

  fuseNegation :: Bool -> IntegralLit -> IntegralLit
  fuseNegation :: Bool -> IntegralLit -> IntegralLit
fuseNegation Bool
negated (IL SourceText
_txt Bool
neg Integer
val) =
    let -- You can write patterns/exprs that are the negation of a neg literal.
        -- We'll just sweep those under the rug by making them into a positive
        -- literal.  If there's more than one negation, too bad.  Those will
        -- try to call into a Num instance.
        neg' :: Bool
neg' = Bool
neg Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
negated

        -- If the thing described in the previous comment happened, we have
        -- e.g. "-4" as the source text.  Just drop the source text always.
        txt' :: SourceText
txt' = SourceText
NoSourceText

        -- Set the sign of the resulting literal according to 'neg''.
        val' :: Integer
val' = (if Bool
neg' then Integer -> Integer
forall a. Num a => a -> a
negate else Integer -> Integer
forall a. a -> a
id) (Integer -> Integer
forall a. Num a => a -> a
abs Integer
val)

        -- Refabricated literal.
    in  SourceText -> Bool -> Integer -> IntegralLit
IL SourceText
txt' Bool
neg' Integer
val'

  buildReprLit :: SrcSpanAnnA -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
  buildReprLit :: SrcSpan -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
buildReprLit SrcSpan
l IntegralLit
il HsExpr GhcPs
witness =
    SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit EpAnn
XOverLitE GhcPs
EpAnnNotUsed (HsOverLit GhcPs -> HsExpr GhcPs)
-> HsOverLit GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XOverLit GhcPs -> OverLitVal -> HsExpr GhcPs -> HsOverLit GhcPs
forall p. XOverLit p -> OverLitVal -> HsExpr p -> HsOverLit p
OverLit EpAnn
XOverLit GhcPs
NoExtField (IntegralLit -> OverLitVal
HsIntegral IntegralLit
il) HsExpr GhcPs
witness

  rewriteLit
    :: SrcSpanAnnA -> Bool -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
  rewriteLit :: SrcSpan -> Bool -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
rewriteLit SrcSpan
l Bool
negated IntegralLit
il HsExpr GhcPs
witness =
    let il' :: IntegralLit
il' = Bool -> IntegralLit -> IntegralLit
fuseNegation Bool
negated IntegralLit
il
        wrapper :: LHsExpr GhcPs
wrapper = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdP GhcPs
RdrName
litHashName LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
`nlHsAppType` IntegralLit -> LHsType GhcPs
litToTyLit IntegralLit
il'
        lit :: LHsExpr GhcPs
lit = SrcSpan -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
buildReprLit SrcSpan
l IntegralLit
il' HsExpr GhcPs
witness
    in  SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnn
XApp GhcPs
EpAnnNotUsed (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
wrapper LHsExpr GhcPs
lit) LHsExpr GhcPs
lit

  foldNegation :: LHsExpr GhcPs -> LHsExpr GhcPs
  foldNegation :: LHsExpr GhcPs -> LHsExpr GhcPs
foldNegation (L SrcSpan
l (NegApp XNegApp GhcPs
_ (L SrcSpan
_ (HsExpr GhcPs -> Maybe (IntegralLit, HsExpr GhcPs)
extractLit -> Just (IntegralLit
il, HsExpr GhcPs
witness))) SyntaxExpr GhcPs
_)) =
    SrcSpan -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
buildReprLit SrcSpan
l (Bool -> IntegralLit -> IntegralLit
fuseNegation Bool
True IntegralLit
il) HsExpr GhcPs
witness
  foldNegation LHsExpr GhcPs
e = LHsExpr GhcPs
e

  transformExp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
  transformExp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
transformExp (L SrcSpan
l (HsExpr GhcPs -> Maybe (IntegralLit, HsExpr GhcPs)
extractLit -> Just (IntegralLit
lit, HsExpr GhcPs
witness))) =
    LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Bool -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
rewriteLit SrcSpan
l Bool
False IntegralLit
lit HsExpr GhcPs
witness
  transformExp LHsExpr GhcPs
_ = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing

  transformPat :: LPat GhcPs -> Maybe (LPat GhcPs)
  transformPat :: LPat GhcPs -> Maybe (LPat GhcPs)
transformPat (LPat (NPat _ (L l (OverLit _ (HsIntegral il) witness)) negation _)) =
    let il' :: IntegralLit
il' = Bool -> IntegralLit -> IntegralLit
fuseNegation (Maybe (SyntaxExpr GhcPs) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SyntaxExpr GhcPs)
negation) IntegralLit
il

        -- Wrapper application of match# to the LitRepr.
        wrappedLit :: LHsExpr GhcPs
wrappedLit =
          IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdP GhcPs
RdrName
matchHashName
            LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
`nlHsAppType` IntegralLit -> LHsType GhcPs
litToTyLit IntegralLit
il'
            LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp_` SrcSpan -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
buildReprLit (SrcSpan -> SrcSpan
toSrcSpanAnnA SrcSpan
l) IntegralLit
il' HsExpr GhcPs
witness
            LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp_` SrcSpan -> IntegralLit -> HsExpr GhcPs -> LHsExpr GhcPs
buildReprLit (SrcSpan -> SrcSpan
toSrcSpanAnnA SrcSpan
l) IntegralLit
il' HsExpr GhcPs
witness

    in  Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs))
forall a. a -> Maybe a
Just (Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs)))
-> Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ Pat GhcPs -> LPat GhcPs
forall (p :: Pass). Pat (GhcPass p) -> LPat (GhcPass p)
nlPat (Pat GhcPs -> LPat GhcPs) -> Pat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat EpAnn
XViewPat GhcPs
EpAnnNotUsed
            LHsExpr GhcPs
wrappedLit
            (Pat GhcPs -> LPat GhcPs
forall (p :: Pass). Pat (GhcPass p) -> LPat (GhcPass p)
nlPat (Pat GhcPs -> LPat GhcPs) -> Pat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ EpAnn -> Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs
forall p a. a -> Located (IdP p) -> HsConPatDetails p -> Pat p
ConPat EpAnn
EpAnnNotUsed (RdrName -> Located RdrName
forall a. a -> Located a
nl RdrName
cjustConName) ([Located (Pat GhcPs)]
-> HsConDetails
     (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
forall arg rec. [arg] -> HsConDetails arg rec
mkPrefixCon []))
  transformPat LPat GhcPs
_ = Maybe (LPat GhcPs)
forall a. Maybe a
Nothing