{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

{-| Provide a pure API for GHC internals.

All GHC operations should go through this API, to isolate
the rest of the logic from GHC internals logic, which can
include breaking changes between versions.
-}
module Skeletest.Internal.GHC (
  Plugin,
  PluginDef (..),
  Ctx (..),
  GhcRn,
  mkPlugin,

  -- * ParsedModule
  ParsedModule (..),
  FunDef (..),

  -- ** Expressions
  HsExpr,
  HsExprData (..),
  hsExprCon,
  hsExprVar,
  hsExprApps,
  hsExprList,
  hsExprRecordCon,
  hsExprLitString,
  hsExprLam,
  hsExprCase,
  getExpr,
  renderHsExpr,

  -- ** Types
  HsType (..),

  -- ** Patterns
  HsPat (..),

  -- ** Names
  HsName,
  hsName,
  hsVarName,
  getHsName,
) where

import Control.Monad.Trans.Class qualified as Trans
import Control.Monad.Trans.State (StateT, evalStateT)
import Control.Monad.Trans.State qualified as State
import Data.Data (Data)
import Data.Data qualified as Data
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable qualified as Typeable
import GHC (
  GenLocated (..),
  GhcPass (..),
  GhcPs,
  GhcRn,
  IsPass,
  unLoc,
 )
import GHC qualified as GHC
import GHC.Driver.Main qualified as GHC
import GHC.Plugins qualified as GHC hiding (getHscEnv)
import GHC.Tc.Utils.Monad qualified as GHC
import GHC.Types.Name qualified as GHC.Name
import GHC.Types.Name.Cache qualified as GHC (NameCache)
import GHC.Types.SourceText qualified as GHC.SourceText
import Language.Haskell.TH.Syntax qualified as TH
import System.IO.Unsafe (unsafePerformIO)

#if !MIN_VERSION_base(4, 20, 0)
import Data.Foldable (foldl')
#endif

import Skeletest.Internal.Error (invariantViolation, skeletestPluginError)
import Skeletest.Internal.GHC.Compat (genLoc)
import Skeletest.Internal.GHC.Compat qualified as GHC.Compat

-- Has to be exactly GHC's Plugin type, for GHC to register it correctly.
type Plugin = GHC.Plugin

-- | Our pure definition of PluginDef, agnostic of GHC version.
data PluginDef = PluginDef
  { PluginDef -> Bool
isPure :: Bool
  , PluginDef -> ModuleName -> ParsedModule -> ParsedModule
modifyParsed :: ModuleName -> ParsedModule -> ParsedModule
  , PluginDef -> Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn
onRename :: Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn
  }

data Ctx = Ctx
  { Ctx -> HsName GhcRn -> HsName GhcRn -> Bool
matchesName :: HsName GhcRn -> HsName GhcRn -> Bool
  }

type ModuleName = Text

mkPlugin :: PluginDef -> Plugin
mkPlugin :: PluginDef -> Plugin
mkPlugin PluginDef{Bool
ModuleName -> ParsedModule -> ParsedModule
Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn
isPure :: PluginDef -> Bool
modifyParsed :: PluginDef -> ModuleName -> ParsedModule -> ParsedModule
onRename :: PluginDef -> Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn
isPure :: Bool
modifyParsed :: ModuleName -> ParsedModule -> ParsedModule
onRename :: Ctx -> ModuleName -> HsExpr GhcRn -> HsExpr GhcRn
..} =
  Plugin
GHC.defaultPlugin
    { GHC.pluginRecompile = if isPure then GHC.purePlugin else GHC.impurePlugin
    , GHC.parsedResultAction = \[String]
_ ModSummary
modInfo ParsedResult
result -> do
        let
          moduleName :: ModuleName
moduleName = GenModule Unit -> ModuleName
forall {unit}. GenModule unit -> ModuleName
getModuleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> GenModule Unit
GHC.ms_mod ModSummary
modInfo
          parsedModule :: ParsedModule
parsedModule = Located (HsModule GhcPs) -> ParsedModule
initParsedModule (Located (HsModule GhcPs) -> ParsedModule)
-> (ParsedResult -> Located (HsModule GhcPs))
-> ParsedResult
-> ParsedModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsParsedModule -> Located (HsModule GhcPs)
GHC.hpm_module (HsParsedModule -> Located (HsModule GhcPs))
-> (ParsedResult -> HsParsedModule)
-> ParsedResult
-> Located (HsModule GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedResult -> HsParsedModule
GHC.parsedResultModule (ParsedResult -> ParsedModule) -> ParsedResult -> ParsedModule
forall a b. (a -> b) -> a -> b
$ ParsedResult
result
          ParsedModule{[(HsName GhcPs, Maybe FunDef)]
moduleFuncs :: [(HsName GhcPs, Maybe FunDef)]
moduleFuncs :: ParsedModule -> [(HsName GhcPs, Maybe FunDef)]
moduleFuncs} = ModuleName -> ParsedModule -> ParsedModule
modifyParsed ModuleName
moduleName ParsedModule
parsedModule
        newDecls <-
          CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. CompilePs a -> Hsc a
runCompilePs (CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
    -> CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> CompilePs [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> CompilePs a -> CompilePs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompilePs [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
    -> CompilePs [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]])
-> [CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> CompilePs [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [CompilePs [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$
            [ HsName GhcPs -> FunDef -> CompilePs [LHsDecl GhcPs]
forall (m :: * -> *).
MonadCompile m GhcPs =>
HsName GhcPs -> FunDef -> m [LHsDecl GhcPs]
compileFunDef HsName GhcPs
funName FunDef
funDef
            | (HsName GhcPs
funName, Just FunDef
funDef) <- [(HsName GhcPs, Maybe FunDef)]
moduleFuncs
            ]
        pure
          . (modifyParsedResultModule . modifyHpmModule . fmap . modifyModDecls) (newDecls <>)
          $ result
    , GHC.renamedResultAction = \[String]
_ TcGblEnv
gblEnv HsGroup GhcRn
group -> do
        nameCache <- HscEnv -> NameCache
GHC.hsc_NC (HscEnv -> NameCache)
-> (Env TcGblEnv TcLclEnv -> HscEnv)
-> Env TcGblEnv TcLclEnv
-> NameCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env TcGblEnv TcLclEnv -> HscEnv
forall gbl lcl. Env gbl lcl -> HscEnv
GHC.env_top (Env TcGblEnv TcLclEnv -> NameCache)
-> IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) NameCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
forall env. IOEnv env env
GHC.getEnv
        let
          moduleName = GenModule Unit -> ModuleName
forall {unit}. GenModule unit -> ModuleName
getModuleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> GenModule Unit
GHC.tcg_mod TcGblEnv
gblEnv
          ctx =
            Ctx
              { matchesName :: HsName GhcRn -> HsName GhcRn -> Bool
matchesName = NameCache -> HsName GhcRn -> HsName GhcRn -> Bool
matchesNameImpl NameCache
nameCache
              }
        group' <- runCompileRn $ modifyModuleExprs (onRename ctx moduleName) group
        pure (gblEnv, group')
    }
  where
    getModuleName :: GenModule unit -> ModuleName
getModuleName GHC.Module{ModuleName
moduleName :: ModuleName
moduleName :: forall unit. GenModule unit -> ModuleName
moduleName} = String -> ModuleName
Text.pack (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
GHC.moduleNameString ModuleName
moduleName

    modifyParsedResultModule :: (HsParsedModule -> HsParsedModule) -> ParsedResult -> ParsedResult
modifyParsedResultModule HsParsedModule -> HsParsedModule
f ParsedResult
x = ParsedResult
x{GHC.parsedResultModule = f $ GHC.parsedResultModule x}
    modifyHpmModule :: (Located (HsModule GhcPs) -> Located (HsModule GhcPs))
-> HsParsedModule -> HsParsedModule
modifyHpmModule Located (HsModule GhcPs) -> Located (HsModule GhcPs)
f HsParsedModule
x = HsParsedModule
x{GHC.hpm_module = f $ GHC.hpm_module x}
    modifyModDecls :: ([XRec p (HsDecl p)] -> [XRec p (HsDecl p)])
-> HsModule p -> HsModule p
modifyModDecls [XRec p (HsDecl p)] -> [XRec p (HsDecl p)]
f HsModule p
x = HsModule p
x{GHC.hsmodDecls = f $ GHC.hsmodDecls x}

{----- ParsedModule -----}

data ParsedModule = ParsedModule
  { ParsedModule -> [(HsName GhcPs, Maybe FunDef)]
moduleFuncs :: [(HsName GhcPs, Maybe FunDef)]
  }

data FunDef = FunDef
  { FunDef -> HsType GhcPs
funType :: HsType GhcPs
  , FunDef -> [HsPat GhcPs]
funPats :: [HsPat GhcPs]
  , FunDef -> HsExpr GhcPs
funBody :: HsExpr GhcPs
  }

initParsedModule :: GHC.Located (GHC.HsModule GhcPs) -> ParsedModule
initParsedModule :: Located (HsModule GhcPs) -> ParsedModule
initParsedModule (L SrcSpan
_ GHC.HsModule{[LHsDecl GhcPs]
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls}) =
  ParsedModule
    { moduleFuncs :: [(HsName GhcPs, Maybe FunDef)]
moduleFuncs =
        [ (HsName GhcPs
funName, Maybe FunDef
forall a. Maybe a
Nothing)
        | Just HsName GhcPs
funName <- (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Maybe (HsName GhcPs))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [Maybe (HsName GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (HsDecl GhcPs -> Maybe (HsName GhcPs)
getValName (HsDecl GhcPs -> Maybe (HsName GhcPs))
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Maybe (HsName GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls
        ]
    }
  where
    getValName :: HsDecl GhcPs -> Maybe (HsName GhcPs)
getValName = \case
      GHC.ValD XValD GhcPs
_ GHC.FunBind{LIdP GhcPs
fun_id :: LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id} -> HsName GhcPs -> Maybe (HsName GhcPs)
forall a. a -> Maybe a
Just (HsName GhcPs -> Maybe (HsName GhcPs))
-> (LIdP GhcPs -> HsName GhcPs)
-> LIdP GhcPs
-> Maybe (HsName GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdP GhcPs -> HsName GhcPs
forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName (IdP GhcPs -> HsName GhcPs)
-> (GenLocated SrcSpanAnnN (IdP GhcPs) -> IdP GhcPs)
-> GenLocated SrcSpanAnnN (IdP GhcPs)
-> HsName GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN (IdP GhcPs) -> IdP GhcPs
forall l e. GenLocated l e -> e
unLoc (LIdP GhcPs -> Maybe (HsName GhcPs))
-> LIdP GhcPs -> Maybe (HsName GhcPs)
forall a b. (a -> b) -> a -> b
$ LIdP GhcPs
fun_id
      HsDecl GhcPs
_ -> Maybe (HsName GhcPs)
forall a. Maybe a
Nothing

{----- modifyModuleExprs -----}

modifyModuleExprs ::
  forall m.
  (MonadCompile m GhcRn) =>
  (HsExpr GhcRn -> HsExpr GhcRn)
  -> GHC.HsGroup GhcRn
  -> m (GHC.HsGroup GhcRn)
modifyModuleExprs :: forall (m :: * -> *).
MonadCompile m GhcRn =>
(HsExpr GhcRn -> HsExpr GhcRn)
-> HsGroup GhcRn -> m (HsGroup GhcRn)
modifyModuleExprs HsExpr GhcRn -> HsExpr GhcRn
f = HsGroup GhcRn -> m (HsGroup GhcRn)
forall a. Data a => a -> m a
go
  where
    go :: (Data a) => a -> m a
    go :: forall a. Data a => a -> m a
go = (forall a. Data a => a -> m a) -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a
Data.gmapM ((forall a. Data a => a -> m a) -> a -> m a)
-> (forall a. Data a => a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ \d
x -> d -> m d
forall a. Data a => a -> m a
updateExpr d
x m d -> (d -> m d) -> m d
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= d -> m d
forall a. Data a => a -> m a
go

    updateExpr :: (Data a) => a -> m a
    updateExpr :: forall a. Data a => a -> m a
updateExpr (a
x :: a) =
      case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
Typeable.eqT @(GHC.LHsExpr GhcRn) @a of
        Just LHsExpr GhcRn :~: a
Typeable.Refl -> HsExpr GhcRn -> m a
HsExpr GhcRn -> m (LHsExpr GhcRn)
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
compileHsExpr (HsExpr GhcRn -> m a) -> (a -> HsExpr GhcRn) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn -> HsExpr GhcRn
f (HsExpr GhcRn -> HsExpr GhcRn)
-> (a -> HsExpr GhcRn) -> a -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HsExpr GhcRn
LHsExpr GhcRn -> HsExpr GhcRn
parseHsExpr (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a
x
        Maybe (LHsExpr GhcRn :~: a)
Nothing -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

{----- HsExpr -----}

-- | A Haskell expression that is either:
--     1. A parsed expression from the compiler
--          * ghcExpr is Just
--          * hsExpr is not HsExprOther if the expression is something
--            we care about parsing, otherwise HsExprOther
--     3. A new expression we're creating
--          * ghcExpr is Nothing
--          * hsExpr is not HsExprOther
--
-- Invariants:
--   * If ghcExpr is Just, hsExpr must not have been modified
--   * if ghcExpr is Nothing, hsExpr is not HsExprOther
data HsExpr p = HsExprUnsafe
  { forall p. HsExpr p -> Maybe (GhcLHsExpr p)
ghcExpr :: Maybe (GhcLHsExpr p)
  , forall p. HsExpr p -> HsExprData p
hsExpr :: HsExprData p
  }
  deriving (Int -> HsExpr p -> ShowS
[HsExpr p] -> ShowS
HsExpr p -> String
(Int -> HsExpr p -> ShowS)
-> (HsExpr p -> String) -> ([HsExpr p] -> ShowS) -> Show (HsExpr p)
forall p. Int -> HsExpr p -> ShowS
forall p. [HsExpr p] -> ShowS
forall p. HsExpr p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Int -> HsExpr p -> ShowS
showsPrec :: Int -> HsExpr p -> ShowS
$cshow :: forall p. HsExpr p -> String
show :: HsExpr p -> String
$cshowList :: forall p. [HsExpr p] -> ShowS
showList :: [HsExpr p] -> ShowS
Show)

data HsExprData p
  = HsExprCon (HsName p)
  | HsExprVar (HsName p)
  | HsExprApps (HsExpr p) [HsExpr p]
  | HsExprOp (HsExpr p) (HsExpr p) (HsExpr p) -- lhs op rhs
  | HsExprList [HsExpr p]
  | HsExprRecordCon (HsName p) [(HsName p, HsExpr p)]
  | HsExprLitString Text
  | HsExprLam [HsPat p] (HsExpr p)
  | HsExprCase (HsExpr p) [(HsPat p, HsExpr p)]
  | HsExprOther
  deriving (Int -> HsExprData p -> ShowS
[HsExprData p] -> ShowS
HsExprData p -> String
(Int -> HsExprData p -> ShowS)
-> (HsExprData p -> String)
-> ([HsExprData p] -> ShowS)
-> Show (HsExprData p)
forall p. Int -> HsExprData p -> ShowS
forall p. [HsExprData p] -> ShowS
forall p. HsExprData p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Int -> HsExprData p -> ShowS
showsPrec :: Int -> HsExprData p -> ShowS
$cshow :: forall p. HsExprData p -> String
show :: HsExprData p -> String
$cshowList :: forall p. [HsExprData p] -> ShowS
showList :: [HsExprData p] -> ShowS
Show)

getExpr :: HsExpr p -> HsExprData p
getExpr :: forall p. HsExpr p -> HsExprData p
getExpr HsExprUnsafe{HsExprData p
hsExpr :: forall p. HsExpr p -> HsExprData p
hsExpr :: HsExprData p
hsExpr} = HsExprData p
hsExpr

renderHsExpr :: HsExpr GhcRn -> Text
renderHsExpr :: HsExpr GhcRn -> ModuleName
renderHsExpr = \case
  HsExprUnsafe{ghcExpr :: forall p. HsExpr p -> Maybe (GhcLHsExpr p)
ghcExpr = Just GhcLHsExpr GhcRn
e} -> String -> ModuleName
Text.pack (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ GhcLHsExpr GhcRn -> String
forall a. Show a => a -> String
show GhcLHsExpr GhcRn
e
  HsExprUnsafe{hsExpr :: forall p. HsExpr p -> HsExprData p
hsExpr = HsExprData GhcRn
e} -> String -> ModuleName
Text.pack (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ HsExprData GhcRn -> String
forall a. Show a => a -> String
show HsExprData GhcRn
e

newHsExpr :: HsExprData p -> HsExpr p
newHsExpr :: forall p. HsExprData p -> HsExpr p
newHsExpr HsExprData p
e =
  HsExprUnsafe
    { ghcExpr :: Maybe (GhcLHsExpr p)
ghcExpr = Maybe (GhcLHsExpr p)
forall a. Maybe a
Nothing
    , hsExpr :: HsExprData p
hsExpr = HsExprData p
e
    }

hsExprCon :: HsName p -> HsExpr p
hsExprCon :: forall p. HsName p -> HsExpr p
hsExprCon = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p)
-> (HsName p -> HsExprData p) -> HsName p -> HsExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName p -> HsExprData p
forall p. HsName p -> HsExprData p
HsExprCon

hsExprVar :: HsName p -> HsExpr p
hsExprVar :: forall p. HsName p -> HsExpr p
hsExprVar = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p)
-> (HsName p -> HsExprData p) -> HsName p -> HsExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName p -> HsExprData p
forall p. HsName p -> HsExprData p
HsExprVar

hsExprApps :: HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps :: forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps HsExpr p
f [HsExpr p]
xs = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p) -> HsExprData p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsExpr p -> [HsExpr p] -> HsExprData p
forall p. HsExpr p -> [HsExpr p] -> HsExprData p
HsExprApps HsExpr p
f [HsExpr p]
xs

hsExprList :: [HsExpr p] -> HsExpr p
hsExprList :: forall p. [HsExpr p] -> HsExpr p
hsExprList = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p)
-> ([HsExpr p] -> HsExprData p) -> [HsExpr p] -> HsExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsExpr p] -> HsExprData p
forall p. [HsExpr p] -> HsExprData p
HsExprList

hsExprRecordCon :: HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
hsExprRecordCon :: forall p. HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
hsExprRecordCon HsName p
conName [(HsName p, HsExpr p)]
fields = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p) -> HsExprData p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsName p -> [(HsName p, HsExpr p)] -> HsExprData p
forall p. HsName p -> [(HsName p, HsExpr p)] -> HsExprData p
HsExprRecordCon HsName p
conName [(HsName p, HsExpr p)]
fields

hsExprLitString :: Text -> HsExpr p
hsExprLitString :: forall p. ModuleName -> HsExpr p
hsExprLitString = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p)
-> (ModuleName -> HsExprData p) -> ModuleName -> HsExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> HsExprData p
forall p. ModuleName -> HsExprData p
HsExprLitString

hsExprLam :: [HsPat p] -> HsExpr p -> HsExpr p
hsExprLam :: forall p. [HsPat p] -> HsExpr p -> HsExpr p
hsExprLam [HsPat p]
args HsExpr p
body = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p) -> HsExprData p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ [HsPat p] -> HsExpr p -> HsExprData p
forall p. [HsPat p] -> HsExpr p -> HsExprData p
HsExprLam [HsPat p]
args HsExpr p
body

hsExprCase :: HsExpr p -> [(HsPat p, HsExpr p)] -> HsExpr p
hsExprCase :: forall p. HsExpr p -> [(HsPat p, HsExpr p)] -> HsExpr p
hsExprCase HsExpr p
e [(HsPat p, HsExpr p)]
branches = HsExprData p -> HsExpr p
forall p. HsExprData p -> HsExpr p
newHsExpr (HsExprData p -> HsExpr p) -> HsExprData p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsExpr p -> [(HsPat p, HsExpr p)] -> HsExprData p
forall p. HsExpr p -> [(HsPat p, HsExpr p)] -> HsExprData p
HsExprCase HsExpr p
e [(HsPat p, HsExpr p)]
branches

parseHsExpr :: GHC.LHsExpr GhcRn -> HsExpr GhcRn
parseHsExpr :: LHsExpr GhcRn -> HsExpr GhcRn
parseHsExpr = LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr
  where
    goExpr :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr GenLocated SrcSpanAnnA (HsExpr GhcRn)
e =
      HsExprUnsafe
        { ghcExpr :: Maybe (GhcLHsExpr GhcRn)
ghcExpr = GhcLHsExpr GhcRn -> Maybe (GhcLHsExpr GhcRn)
forall a. a -> Maybe a
Just (GhcLHsExpr GhcRn -> Maybe (GhcLHsExpr GhcRn))
-> GhcLHsExpr GhcRn -> Maybe (GhcLHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> GhcLHsExpr GhcRn
GhcLHsExprRn LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e
        , hsExpr :: HsExprData GhcRn
hsExpr = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExprData GhcRn
goData GenLocated SrcSpanAnnA (HsExpr GhcRn)
e
        }

    goData :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExprData GhcRn
goData = \case
      L SrcSpanAnnA
_ (GHC.HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
name)) ->
        if (OccName -> NameSpace
GHC.occNameSpace (OccName -> NameSpace) -> (Name -> OccName) -> Name -> NameSpace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall name. HasOccName name => name -> OccName
GHC.occName) Name
name NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
GHC.Name.dataName
          then HsName GhcRn -> HsExprData GhcRn
forall p. HsName p -> HsExprData p
HsExprCon (IdP GhcRn -> HsName GhcRn
forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName IdP GhcRn
Name
name)
          else HsName GhcRn -> HsExprData GhcRn
forall p. HsName p -> HsExprData p
HsExprVar (IdP GhcRn -> HsName GhcRn
forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName IdP GhcRn
Name
name)
      e :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
e@(L SrcSpanAnnA
_ GHC.HsApp{}) ->
        let (GenLocated SrcSpanAnnA (HsExpr GhcRn)
f, [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
xs) = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> (GenLocated SrcSpanAnnA (HsExpr GhcRn),
    [GenLocated SrcSpanAnnA (HsExpr GhcRn)])
collectApps GenLocated SrcSpanAnnA (HsExpr GhcRn)
e
         in HsExpr GhcRn -> [HsExpr GhcRn] -> HsExprData GhcRn
forall p. HsExpr p -> [HsExpr p] -> HsExprData p
HsExprApps (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr GenLocated SrcSpanAnnA (HsExpr GhcRn)
f) ((GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)] -> [HsExpr GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
xs)
      L SrcSpanAnnA
_ (GHC.OpApp XOpApp GhcRn
_ LHsExpr GhcRn
lhs LHsExpr GhcRn
op LHsExpr GhcRn
rhs) ->
        HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExpr p -> HsExpr p -> HsExprData p
HsExprOp (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
lhs) (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op) (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs)
      L SrcSpanAnnA
_ (GHC.RecordCon XRecordCon GhcRn
_ XRec GhcRn (ConLikeP GhcRn)
conName GHC.HsRecFields{[LHsRecField GhcRn (LHsExpr GhcRn)]
rec_flds :: [LHsRecField GhcRn (LHsExpr GhcRn)]
rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds}) ->
        HsName GhcRn -> [(HsName GhcRn, HsExpr GhcRn)] -> HsExprData GhcRn
forall p. HsName p -> [(HsName p, HsExpr p)] -> HsExprData p
HsExprRecordCon (IdP GhcRn -> HsName GhcRn
forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName (IdP GhcRn -> HsName GhcRn) -> IdP GhcRn -> HsName GhcRn
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc XRec GhcRn (ConLikeP GhcRn)
GenLocated SrcSpanAnnN Name
conName) ([(HsName GhcRn, HsExpr GhcRn)] -> HsExprData GhcRn)
-> [(HsName GhcRn, HsExpr GhcRn)] -> HsExprData GhcRn
forall a b. (a -> b) -> a -> b
$ (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> (HsName GhcRn, HsExpr GhcRn))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [(HsName GhcRn, HsExpr GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> (HsName GhcRn, HsExpr GhcRn)
getRecField (HsFieldBind
   (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
   (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> (HsName GhcRn, HsExpr GhcRn))
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
        (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> (HsName GhcRn, HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [LHsRecField GhcRn (LHsExpr GhcRn)]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rec_flds
      L SrcSpanAnnA
_ par :: HsExpr GhcRn
par@GHC.HsPar{} -> LHsExpr GhcRn -> HsExprData GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExprData GhcRn
goData (LHsExpr GhcRn -> HsExprData GhcRn)
-> LHsExpr GhcRn -> HsExprData GhcRn
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> LHsExpr GhcRn
GHC.Compat.unHsPar HsExpr GhcRn
par
      GenLocated SrcSpanAnnA (HsExpr GhcRn)
_ -> HsExprData GhcRn
forall p. HsExprData p
HsExprOther

    getRecField :: HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> (HsName GhcRn, HsExpr GhcRn)
getRecField GHC.HsFieldBind{hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = GenLocated SrcSpanAnnA (FieldOcc GhcRn)
field, hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr} =
      (IdP GhcRn -> HsName GhcRn
Name -> HsName GhcRn
forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName (Name -> HsName GhcRn)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> Name)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> HsName GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn)
    -> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldOcc GhcRn -> LIdP GhcRn
FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name
GHC.Compat.foLabel (FieldOcc GhcRn -> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn)
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> FieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> HsName GhcRn)
-> GenLocated SrcSpanAnnA (FieldOcc GhcRn) -> HsName GhcRn
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (FieldOcc GhcRn)
field, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
goExpr GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr)

    -- Collect an application of the form `((f a) b) c` and return `f [a, b, c]`
    collectApps :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> (GenLocated SrcSpanAnnA (HsExpr GhcRn),
    [GenLocated SrcSpanAnnA (HsExpr GhcRn)])
collectApps = \case
      L SrcSpanAnnA
_ (GHC.HsApp XApp GhcRn
_ LHsExpr GhcRn
l LHsExpr GhcRn
r) -> let (GenLocated SrcSpanAnnA (HsExpr GhcRn)
f, [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
xs) = GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> (GenLocated SrcSpanAnnA (HsExpr GhcRn),
    [GenLocated SrcSpanAnnA (HsExpr GhcRn)])
collectApps LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
l in (GenLocated SrcSpanAnnA (HsExpr GhcRn)
f, [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
xs [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall a. Semigroup a => a -> a -> a
<> [LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
r])
      GenLocated SrcSpanAnnA (HsExpr GhcRn)
e -> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e, [])

{----- HsType -----}

data HsType p
  = HsTypeCon (HsName p)
  | HsTypeApps (HsType p) [HsType p]
  | HsTypeTuple [HsType p]

{----- HsPat -----}

data HsPat p
  = HsPatCon (HsName p) [HsPat p]
  | HsPatVar (HsName p)
  | HsPatRecord (HsName p) [(HsName p, HsPat p)]
  | HsPatWild
  deriving (Int -> HsPat p -> ShowS
[HsPat p] -> ShowS
HsPat p -> String
(Int -> HsPat p -> ShowS)
-> (HsPat p -> String) -> ([HsPat p] -> ShowS) -> Show (HsPat p)
forall p. Int -> HsPat p -> ShowS
forall p. [HsPat p] -> ShowS
forall p. HsPat p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Int -> HsPat p -> ShowS
showsPrec :: Int -> HsPat p -> ShowS
$cshow :: forall p. HsPat p -> String
show :: HsPat p -> String
$cshowList :: forall p. [HsPat p] -> ShowS
showList :: [HsPat p] -> ShowS
Show)

{----- HsName -----}

data HsName p
  = HsName TH.Name
  | HsVarName Text
  | HsGhcName (GhcIdP p)
  deriving (Int -> HsName p -> ShowS
[HsName p] -> ShowS
HsName p -> String
(Int -> HsName p -> ShowS)
-> (HsName p -> String) -> ([HsName p] -> ShowS) -> Show (HsName p)
forall p. Int -> HsName p -> ShowS
forall p. [HsName p] -> ShowS
forall p. HsName p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Int -> HsName p -> ShowS
showsPrec :: Int -> HsName p -> ShowS
$cshow :: forall p. HsName p -> String
show :: HsName p -> String
$cshowList :: forall p. [HsName p] -> ShowS
showList :: [HsName p] -> ShowS
Show, HsName p -> HsName p -> Bool
(HsName p -> HsName p -> Bool)
-> (HsName p -> HsName p -> Bool) -> Eq (HsName p)
forall p. HsName p -> HsName p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall p. HsName p -> HsName p -> Bool
== :: HsName p -> HsName p -> Bool
$c/= :: forall p. HsName p -> HsName p -> Bool
/= :: HsName p -> HsName p -> Bool
Eq)

hsName :: TH.Name -> HsName p
hsName :: forall p. Name -> HsName p
hsName = Name -> HsName p
forall p. Name -> HsName p
HsName

hsVarName :: Text -> HsName p
hsVarName :: forall p. ModuleName -> HsName p
hsVarName = ModuleName -> HsName p
forall p. ModuleName -> HsName p
HsVarName

hsGhcName :: forall p. (IsPass p) => GHC.IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName :: forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> HsName (GhcPass p)
hsGhcName = GhcIdP (GhcPass p) -> HsName (GhcPass p)
forall p. GhcIdP p -> HsName p
HsGhcName (GhcIdP (GhcPass p) -> HsName (GhcPass p))
-> (IdGhcP p -> GhcIdP (GhcPass p))
-> IdGhcP p
-> HsName (GhcPass p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p (p ~ 'Parsed) => IdGhcP p -> GhcIdP (GhcPass p)
RdrName -> GhcIdP GhcPs
IdGhcP p -> GhcIdP (GhcPass p)
GhcIdPs (p ~ 'Renamed) => IdGhcP p -> GhcIdP (GhcPass p)
Name -> GhcIdP GhcRn
IdGhcP p -> GhcIdP (GhcPass p)
GhcIdRn

fromTHName :: GHC.NameCache -> TH.Name -> GHC.Name
fromTHName :: NameCache -> Name -> Name
fromTHName NameCache
nameCache Name
name =
  case IO (Maybe Name) -> Maybe Name
forall a. IO a -> a
unsafePerformIO (IO (Maybe Name) -> Maybe Name) -> IO (Maybe Name) -> Maybe Name
forall a b. (a -> b) -> a -> b
$ NameCache -> Name -> IO (Maybe Name)
GHC.thNameToGhcNameIO NameCache
nameCache Name
name of
    Just Name
n -> Name
n
    Maybe Name
Nothing -> String -> Name
forall a. String -> a
skeletestPluginError (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Could not get Name for `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"`"

matchesNameImpl :: GHC.NameCache -> HsName GhcRn -> HsName GhcRn -> Bool
matchesNameImpl :: NameCache -> HsName GhcRn -> HsName GhcRn -> Bool
matchesNameImpl NameCache
nameCache HsName GhcRn
n1 HsName GhcRn
n2 = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool) -> Maybe Name -> Maybe (Name -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName GhcRn -> Maybe Name
go HsName GhcRn
n1 Maybe (Name -> Bool) -> Maybe Name -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HsName GhcRn -> Maybe Name
go HsName GhcRn
n2
  where
    go :: HsName GhcRn -> Maybe Name
go = \case
      HsName Name
name -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ NameCache -> Name -> Name
fromTHName NameCache
nameCache Name
name
      HsVarName ModuleName
_ -> Maybe Name
forall a. Maybe a
Nothing -- new names will never match
      HsGhcName GhcIdP GhcRn
name -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ GhcIdP GhcRn -> IdP GhcRn
forall p. GhcIdP p -> IdP p
unGhcIdP GhcIdP GhcRn
name

getHsName :: HsName p -> Text
getHsName :: forall p. HsName p -> ModuleName
getHsName = \case
  HsName Name
name -> String -> ModuleName
Text.pack (String -> ModuleName) -> (Name -> String) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
TH.nameBase (Name -> ModuleName) -> Name -> ModuleName
forall a b. (a -> b) -> a -> b
$ Name
name
  HsVarName ModuleName
name -> ModuleName
name
  HsGhcName (GhcIdPs RdrName
name) -> String -> ModuleName
Text.pack (String -> ModuleName)
-> (RdrName -> String) -> RdrName -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
GHC.occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
GHC.rdrNameOcc (RdrName -> ModuleName) -> RdrName -> ModuleName
forall a b. (a -> b) -> a -> b
$ RdrName
name
  HsGhcName (GhcIdRn Name
name) -> String -> ModuleName
Text.pack (String -> ModuleName) -> (Name -> String) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
GHC.occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
GHC.nameOccName (Name -> ModuleName) -> Name -> ModuleName
forall a b. (a -> b) -> a -> b
$ Name
name

{----- Compilation -----}

class (Monad m) => MonadHasNameCache m where
  getNameCache :: m GHC.NameCache
class (Monad m) => MonadCompileName m p where
  mkIdP :: Text -> m (GHC.IdP p)

type MonadCompile m p = (MonadHasNameCache m, MonadCompileName m p)

newtype CompilePs a = CompilePs (GHC.Hsc a)
  deriving ((forall a b. (a -> b) -> CompilePs a -> CompilePs b)
-> (forall a b. a -> CompilePs b -> CompilePs a)
-> Functor CompilePs
forall a b. a -> CompilePs b -> CompilePs a
forall a b. (a -> b) -> CompilePs a -> CompilePs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CompilePs a -> CompilePs b
fmap :: forall a b. (a -> b) -> CompilePs a -> CompilePs b
$c<$ :: forall a b. a -> CompilePs b -> CompilePs a
<$ :: forall a b. a -> CompilePs b -> CompilePs a
Functor, Functor CompilePs
Functor CompilePs =>
(forall a. a -> CompilePs a)
-> (forall a b. CompilePs (a -> b) -> CompilePs a -> CompilePs b)
-> (forall a b c.
    (a -> b -> c) -> CompilePs a -> CompilePs b -> CompilePs c)
-> (forall a b. CompilePs a -> CompilePs b -> CompilePs b)
-> (forall a b. CompilePs a -> CompilePs b -> CompilePs a)
-> Applicative CompilePs
forall a. a -> CompilePs a
forall a b. CompilePs a -> CompilePs b -> CompilePs a
forall a b. CompilePs a -> CompilePs b -> CompilePs b
forall a b. CompilePs (a -> b) -> CompilePs a -> CompilePs b
forall a b c.
(a -> b -> c) -> CompilePs a -> CompilePs b -> CompilePs c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CompilePs a
pure :: forall a. a -> CompilePs a
$c<*> :: forall a b. CompilePs (a -> b) -> CompilePs a -> CompilePs b
<*> :: forall a b. CompilePs (a -> b) -> CompilePs a -> CompilePs b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CompilePs a -> CompilePs b -> CompilePs c
liftA2 :: forall a b c.
(a -> b -> c) -> CompilePs a -> CompilePs b -> CompilePs c
$c*> :: forall a b. CompilePs a -> CompilePs b -> CompilePs b
*> :: forall a b. CompilePs a -> CompilePs b -> CompilePs b
$c<* :: forall a b. CompilePs a -> CompilePs b -> CompilePs a
<* :: forall a b. CompilePs a -> CompilePs b -> CompilePs a
Applicative, Applicative CompilePs
Applicative CompilePs =>
(forall a b. CompilePs a -> (a -> CompilePs b) -> CompilePs b)
-> (forall a b. CompilePs a -> CompilePs b -> CompilePs b)
-> (forall a. a -> CompilePs a)
-> Monad CompilePs
forall a. a -> CompilePs a
forall a b. CompilePs a -> CompilePs b -> CompilePs b
forall a b. CompilePs a -> (a -> CompilePs b) -> CompilePs b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CompilePs a -> (a -> CompilePs b) -> CompilePs b
>>= :: forall a b. CompilePs a -> (a -> CompilePs b) -> CompilePs b
$c>> :: forall a b. CompilePs a -> CompilePs b -> CompilePs b
>> :: forall a b. CompilePs a -> CompilePs b -> CompilePs b
$creturn :: forall a. a -> CompilePs a
return :: forall a. a -> CompilePs a
Monad)

runCompilePs :: CompilePs a -> GHC.Hsc a
runCompilePs :: forall a. CompilePs a -> Hsc a
runCompilePs (CompilePs Hsc a
m) = Hsc a
m

instance MonadHasNameCache CompilePs where
  getNameCache :: CompilePs NameCache
getNameCache = HscEnv -> NameCache
GHC.hsc_NC (HscEnv -> NameCache) -> CompilePs HscEnv -> CompilePs NameCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc HscEnv -> CompilePs HscEnv
forall a. Hsc a -> CompilePs a
CompilePs Hsc HscEnv
GHC.getHscEnv
instance MonadCompileName CompilePs GhcPs where
  mkIdP :: ModuleName -> CompilePs (IdP GhcPs)
mkIdP = RdrName -> CompilePs RdrName
forall a. a -> CompilePs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RdrName -> CompilePs RdrName)
-> (ModuleName -> RdrName) -> ModuleName -> CompilePs RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> FastString -> RdrName
GHC.mkUnqual NameSpace
GHC.Name.varName (FastString -> RdrName)
-> (ModuleName -> FastString) -> ModuleName -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FastString
fsText

newtype CompileRn a = CompileRn (StateT (Map Text GHC.Name) GHC.TcM a)
  deriving ((forall a b. (a -> b) -> CompileRn a -> CompileRn b)
-> (forall a b. a -> CompileRn b -> CompileRn a)
-> Functor CompileRn
forall a b. a -> CompileRn b -> CompileRn a
forall a b. (a -> b) -> CompileRn a -> CompileRn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CompileRn a -> CompileRn b
fmap :: forall a b. (a -> b) -> CompileRn a -> CompileRn b
$c<$ :: forall a b. a -> CompileRn b -> CompileRn a
<$ :: forall a b. a -> CompileRn b -> CompileRn a
Functor, Functor CompileRn
Functor CompileRn =>
(forall a. a -> CompileRn a)
-> (forall a b. CompileRn (a -> b) -> CompileRn a -> CompileRn b)
-> (forall a b c.
    (a -> b -> c) -> CompileRn a -> CompileRn b -> CompileRn c)
-> (forall a b. CompileRn a -> CompileRn b -> CompileRn b)
-> (forall a b. CompileRn a -> CompileRn b -> CompileRn a)
-> Applicative CompileRn
forall a. a -> CompileRn a
forall a b. CompileRn a -> CompileRn b -> CompileRn a
forall a b. CompileRn a -> CompileRn b -> CompileRn b
forall a b. CompileRn (a -> b) -> CompileRn a -> CompileRn b
forall a b c.
(a -> b -> c) -> CompileRn a -> CompileRn b -> CompileRn c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CompileRn a
pure :: forall a. a -> CompileRn a
$c<*> :: forall a b. CompileRn (a -> b) -> CompileRn a -> CompileRn b
<*> :: forall a b. CompileRn (a -> b) -> CompileRn a -> CompileRn b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CompileRn a -> CompileRn b -> CompileRn c
liftA2 :: forall a b c.
(a -> b -> c) -> CompileRn a -> CompileRn b -> CompileRn c
$c*> :: forall a b. CompileRn a -> CompileRn b -> CompileRn b
*> :: forall a b. CompileRn a -> CompileRn b -> CompileRn b
$c<* :: forall a b. CompileRn a -> CompileRn b -> CompileRn a
<* :: forall a b. CompileRn a -> CompileRn b -> CompileRn a
Applicative, Applicative CompileRn
Applicative CompileRn =>
(forall a b. CompileRn a -> (a -> CompileRn b) -> CompileRn b)
-> (forall a b. CompileRn a -> CompileRn b -> CompileRn b)
-> (forall a. a -> CompileRn a)
-> Monad CompileRn
forall a. a -> CompileRn a
forall a b. CompileRn a -> CompileRn b -> CompileRn b
forall a b. CompileRn a -> (a -> CompileRn b) -> CompileRn b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CompileRn a -> (a -> CompileRn b) -> CompileRn b
>>= :: forall a b. CompileRn a -> (a -> CompileRn b) -> CompileRn b
$c>> :: forall a b. CompileRn a -> CompileRn b -> CompileRn b
>> :: forall a b. CompileRn a -> CompileRn b -> CompileRn b
$creturn :: forall a. a -> CompileRn a
return :: forall a. a -> CompileRn a
Monad)

runCompileRn :: CompileRn a -> GHC.TcM a
runCompileRn :: forall a. CompileRn a -> TcM a
runCompileRn (CompileRn StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
m) = StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
-> Map ModuleName Name -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
m Map ModuleName Name
forall k a. Map k a
Map.empty

instance MonadHasNameCache CompileRn where
  getNameCache :: CompileRn NameCache
getNameCache = HscEnv -> NameCache
GHC.hsc_NC (HscEnv -> NameCache)
-> (Env TcGblEnv TcLclEnv -> HscEnv)
-> Env TcGblEnv TcLclEnv
-> NameCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env TcGblEnv TcLclEnv -> HscEnv
forall gbl lcl. Env gbl lcl -> HscEnv
GHC.env_top (Env TcGblEnv TcLclEnv -> NameCache)
-> CompileRn (Env TcGblEnv TcLclEnv) -> CompileRn NameCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateT
  (Map ModuleName Name)
  (IOEnv (Env TcGblEnv TcLclEnv))
  (Env TcGblEnv TcLclEnv)
-> CompileRn (Env TcGblEnv TcLclEnv)
forall a.
StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
-> CompileRn a
CompileRn (StateT
   (Map ModuleName Name)
   (IOEnv (Env TcGblEnv TcLclEnv))
   (Env TcGblEnv TcLclEnv)
 -> CompileRn (Env TcGblEnv TcLclEnv))
-> (IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
    -> StateT
         (Map ModuleName Name)
         (IOEnv (Env TcGblEnv TcLclEnv))
         (Env TcGblEnv TcLclEnv))
-> IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
-> CompileRn (Env TcGblEnv TcLclEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
-> StateT
     (Map ModuleName Name)
     (IOEnv (Env TcGblEnv TcLclEnv))
     (Env TcGblEnv TcLclEnv)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map ModuleName Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift) IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
forall env. IOEnv env env
GHC.getEnv
instance MonadCompileName CompileRn GhcRn where
  mkIdP :: ModuleName -> CompileRn (IdP GhcRn)
mkIdP ModuleName
name = do
    nameMap <- StateT
  (Map ModuleName Name)
  (IOEnv (Env TcGblEnv TcLclEnv))
  (Map ModuleName Name)
-> CompileRn (Map ModuleName Name)
forall a.
StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
-> CompileRn a
CompileRn StateT
  (Map ModuleName Name)
  (IOEnv (Env TcGblEnv TcLclEnv))
  (Map ModuleName Name)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
    case Map.lookup name nameMap of
      Just Name
name' -> Name -> CompileRn Name
forall a. a -> CompileRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name'
      Maybe Name
Nothing -> do
        uniq <- (StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) Unique
-> CompileRn Unique
forall a.
StateT (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) a
-> CompileRn a
CompileRn (StateT
   (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) Unique
 -> CompileRn Unique)
-> (TcM Unique
    -> StateT
         (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) Unique)
-> TcM Unique
-> CompileRn Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcM Unique
-> StateT
     (Map ModuleName Name) (IOEnv (Env TcGblEnv TcLclEnv)) Unique
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map ModuleName Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift) TcM Unique
forall (m :: * -> *). MonadUnique m => m Unique
GHC.getUniqueM
        let name' = Unique -> FastString -> Name
GHC.mkSystemVarName Unique
uniq (ModuleName -> FastString
fsText ModuleName
name)
        CompileRn $ State.put (Map.insert name name' nameMap)
        pure name'

compileHsName ::
  forall p m.
  (GHC.IsPass p, MonadCompile m (GhcPass p)) =>
  HsName (GhcPass p)
  -> m (GHC.IdP (GhcPass p))
compileHsName :: forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName = \case
  HsName Name
name -> do
    nameCache <- m NameCache
forall (m :: * -> *). MonadHasNameCache m => m NameCache
getNameCache
    pure . onPsOrRn @p GHC.getRdrName id $ fromTHName nameCache name
  HsVarName ModuleName
name -> forall (m :: * -> *) p.
MonadCompileName m p =>
ModuleName -> m (IdP p)
mkIdP @_ @(GhcPass p) ModuleName
name
  HsGhcName GhcIdP (GhcPass p)
name -> IdP (GhcPass p) -> m (IdP (GhcPass p))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdP (GhcPass p) -> m (IdP (GhcPass p)))
-> IdP (GhcPass p) -> m (IdP (GhcPass p))
forall a b. (a -> b) -> a -> b
$ GhcIdP (GhcPass p) -> IdP (GhcPass p)
forall p. GhcIdP p -> IdP p
unGhcIdP GhcIdP (GhcPass p)
name

compileFunDef :: (MonadCompile m GhcPs) => HsName GhcPs -> FunDef -> m [GHC.LHsDecl GhcPs]
compileFunDef :: forall (m :: * -> *).
MonadCompile m GhcPs =>
HsName GhcPs -> FunDef -> m [LHsDecl GhcPs]
compileFunDef HsName GhcPs
funName FunDef{[HsPat GhcPs]
HsType GhcPs
HsExpr GhcPs
funType :: FunDef -> HsType GhcPs
funPats :: FunDef -> [HsPat GhcPs]
funBody :: FunDef -> HsExpr GhcPs
funType :: HsType GhcPs
funPats :: [HsPat GhcPs]
funBody :: HsExpr GhcPs
..} = do
  name <- HsName GhcPs -> m (IdP GhcPs)
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName GhcPs
funName
  ty <- compileHsType funType
  pats <- mapM compileHsPat funPats
  body <- compileHsExpr funBody
  pure
    [ mkSigD name ty
    , genLoc . GHC.ValD GHC.noExtField $
        GHC.FunBind GHC.noExtField (genLoc name) . GHC.MG GHC.FromSource . genLoc $
          [ genLoc
              GHC.Match
                { m_ext = GHC.Compat.xMatch
                , m_ctxt = GHC.Compat.mkPrefixFunRhs (genLoc name) GHC.noAnn
                , m_pats = GHC.Compat.toMatchArgs pats
                , m_grhss =
                    GHC.GRHSs
                      { grhssExt = GHC.emptyComments
                      , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body]
                      , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField
                      }
                }
          ]
    ]
  where
    mkSigD :: IdP pass -> XRec pass (HsType pass) -> GenLocated ann (HsDecl pass)
mkSigD IdP pass
name XRec pass (HsType pass)
ty =
      HsDecl pass -> GenLocated ann (HsDecl pass)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc
        (HsDecl pass -> GenLocated ann (HsDecl pass))
-> (HsSigType pass -> HsDecl pass)
-> HsSigType pass
-> GenLocated ann (HsDecl pass)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSigD pass -> Sig pass -> HsDecl pass
forall p. XSigD p -> Sig p -> HsDecl p
GHC.SigD XSigD pass
NoExtField
GHC.noExtField
        (Sig pass -> HsDecl pass)
-> (HsSigType pass -> Sig pass) -> HsSigType pass -> HsDecl pass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTypeSig pass
-> [XRec pass (IdP pass)] -> LHsSigWcType pass -> Sig pass
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
GHC.TypeSig XTypeSig pass
forall a. NoAnn a => a
GHC.noAnn [IdP pass -> GenLocated ann (IdP pass)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc IdP pass
name]
        (HsWildCardBndrs pass (GenLocated ann (HsSigType pass))
 -> Sig pass)
-> (HsSigType pass
    -> HsWildCardBndrs pass (GenLocated ann (HsSigType pass)))
-> HsSigType pass
-> Sig pass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsWC pass (GenLocated ann (HsSigType pass))
-> GenLocated ann (HsSigType pass)
-> HsWildCardBndrs pass (GenLocated ann (HsSigType pass))
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
GHC.HsWC XHsWC pass (GenLocated ann (HsSigType pass))
NoExtField
GHC.noExtField
        (GenLocated ann (HsSigType pass)
 -> HsWildCardBndrs pass (GenLocated ann (HsSigType pass)))
-> (HsSigType pass -> GenLocated ann (HsSigType pass))
-> HsSigType pass
-> HsWildCardBndrs pass (GenLocated ann (HsSigType pass))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsSigType pass -> GenLocated ann (HsSigType pass)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc
        (HsSigType pass -> GenLocated ann (HsDecl pass))
-> HsSigType pass -> GenLocated ann (HsDecl pass)
forall a b. (a -> b) -> a -> b
$ XHsSig pass
-> HsOuterSigTyVarBndrs pass
-> XRec pass (HsType pass)
-> HsSigType pass
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
GHC.HsSig XHsSig pass
NoExtField
GHC.noExtField (XHsOuterImplicit pass -> HsOuterSigTyVarBndrs pass
forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
GHC.HsOuterImplicit XHsOuterImplicit pass
NoExtField
GHC.noExtField) XRec pass (HsType pass)
ty

compileHsType :: (MonadCompile m GhcPs) => HsType GhcPs -> m (GHC.LHsType GhcPs)
compileHsType :: forall (m :: * -> *).
MonadCompile m GhcPs =>
HsType GhcPs -> m (LHsType GhcPs)
compileHsType = HsType GhcPs -> m (LHsType GhcPs)
HsType GhcPs -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
go
  where
    go :: HsType GhcPs -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
go = \case
      HsTypeCon HsName GhcPs
name -> do
        HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (IdP GhcPs -> HsType GhcPs)
-> IdP GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
GHC.HsTyVar XTyVar GhcPs
forall a. NoAnn a => a
GHC.noAnn PromotionFlag
GHC.NotPromoted (GenLocated SrcSpanAnnN (IdP GhcPs) -> HsType GhcPs)
-> (IdP GhcPs -> GenLocated SrcSpanAnnN (IdP GhcPs))
-> IdP GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdP GhcPs -> GenLocated SrcSpanAnnN (IdP GhcPs)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (IdP GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (IdP GhcPs) -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName GhcPs -> m (IdP GhcPs)
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName GhcPs
name
      HsTypeApps HsType GhcPs
ty0 [HsType GhcPs]
tys -> do
        ty0' <- HsType GhcPs -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
go HsType GhcPs
ty0
        tys' <- mapM go tys
        pure $ foldl' (\GenLocated SrcSpanAnnA (HsType GhcPs)
l GenLocated SrcSpanAnnA (HsType GhcPs)
r -> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType 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
GHC.HsAppTy XAppTy GhcPs
NoExtField
GHC.noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
l LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
r) ty0' tys'
      HsTypeTuple [HsType GhcPs]
tys -> do
        tys' <- (HsType GhcPs -> m (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsType GhcPs] -> m [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsType GhcPs -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
go [HsType GhcPs]
tys
        pure . genLoc $ GHC.HsTupleTy GHC.noAnn GHC.HsBoxedOrConstraintTuple tys'

compileHsPat ::
  forall p m.
  (IsPass p, MonadCompile m (GhcPass p)) =>
  HsPat (GhcPass p)
  -> m (GHC.LPat (GhcPass p))
compileHsPat :: forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsPat (GhcPass p) -> m (LPat (GhcPass p))
compileHsPat = HsPat (GhcPass p) -> m (XRec (GhcPass p) (Pat (GhcPass p)))
HsPat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
go
  where
    go :: HsPat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
go = \case
      HsPatCon HsName (GhcPass p)
conName [HsPat (GhcPass p)]
args -> do
        conName' <- HsName (GhcPass p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
fromConName HsName (GhcPass p)
conName
        con <- GHC.PrefixCon [] <$> mapM go args
        pure . genLoc $
          GHC.ConPat
            (onPsOrRn @p GHC.noAnn GHC.noExtField)
            conName'
            con
      HsPatVar HsName (GhcPass p)
name -> do
        name' <- forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p (p ~ 'Parsed) =>
IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
IdGhcP p -> GenLocated SrcSpanAnnN (IdGhcP p)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (p ~ 'Renamed) =>
IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p)
IdGhcP p -> GenLocated SrcSpanAnnN (IdGhcP p)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p))
-> m (IdGhcP p) -> m (GenLocated (Anno (IdGhcP p)) (IdGhcP p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName (GhcPass p) -> m (IdP (GhcPass p))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName (GhcPass p)
name
        pure . genLoc $ GHC.VarPat GHC.noExtField name'
      HsPatRecord HsName (GhcPass p)
conName [(HsName (GhcPass p), HsPat (GhcPass p))]
fields -> do
        conName' <- HsName (GhcPass p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
fromConName HsName (GhcPass p)
conName
        con <- GHC.RecCon <$> compileRecFields go fields
        pure . genLoc $
          GHC.ConPat
            (onPsOrRn @p GHC.noAnn GHC.noExtField)
            conName'
            con
      HsPat (GhcPass p)
HsPatWild -> do
        GenLocated SrcSpanAnnA (Pat (GhcPass p))
-> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (Pat (GhcPass p))
 -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p))))
-> (Pat (GhcPass p) -> GenLocated SrcSpanAnnA (Pat (GhcPass p)))
-> Pat (GhcPass p)
-> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat (GhcPass p) -> GenLocated SrcSpanAnnA (Pat (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (Pat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p))))
-> Pat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
forall a b. (a -> b) -> a -> b
$ XWildPat (GhcPass p) -> Pat (GhcPass p)
forall p. XWildPat p -> Pat p
GHC.WildPat (XWildPat (GhcPass p) -> Pat (GhcPass p))
-> XWildPat (GhcPass p) -> Pat (GhcPass p)
forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p XWildPat (GhcPass p)
NoExtField
(p ~ 'Parsed) => XWildPat (GhcPass p)
GHC.noExtField XWildPat (GhcPass p)
NoExtField
(p ~ 'Renamed) => XWildPat (GhcPass p)
GHC.noExtField

    fromConName :: HsName (GhcPass p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
fromConName = (IdGhcP p
 -> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
-> m (IdGhcP p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p (p ~ 'Parsed) =>
IdGhcP p
-> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p))
IdGhcP p
-> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p))
IdGhcP p -> GenLocated SrcSpanAnnN (IdGhcP p)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (p ~ 'Renamed) =>
IdGhcP p
-> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p))
IdGhcP p
-> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p))
IdGhcP p -> GenLocated SrcSpanAnnN (IdGhcP p)
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc) (m (IdGhcP p)
 -> m (GenLocated
         (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p))))
-> (HsName (GhcPass p) -> m (IdGhcP p))
-> HsName (GhcPass p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName (GhcPass p) -> m (IdP (GhcPass p))
HsName (GhcPass p) -> m (IdGhcP p)
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName

compileHsExpr ::
  forall p m.
  (IsPass p, MonadCompile m (GhcPass p)) =>
  HsExpr (GhcPass p)
  -> m (GHC.LHsExpr (GhcPass p))
compileHsExpr :: forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
compileHsExpr = HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
goExpr
  where
    goExpr :: HsExpr (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))
    goExpr :: HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
goExpr = \case
      HsExprUnsafe{ghcExpr :: forall p. HsExpr p -> Maybe (GhcLHsExpr p)
ghcExpr = Just GhcLHsExpr (GhcPass p)
e} -> LHsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr (GhcPass p) -> m (LHsExpr (GhcPass p)))
-> LHsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$ GhcLHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
forall p. GhcLHsExpr p -> LHsExpr p
unGhcLHsExpr GhcLHsExpr (GhcPass p)
e
      HsExprUnsafe{hsExpr :: forall p. HsExpr p -> HsExprData p
hsExpr = HsExprData (GhcPass p)
e} -> HsExprData (GhcPass p) -> m (LHsExpr (GhcPass p))
goData HsExprData (GhcPass p)
e

    goData :: HsExprData (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))
    goData :: HsExprData (GhcPass p) -> m (LHsExpr (GhcPass p))
goData = \case
      HsExprCon HsName (GhcPass p)
name -> do
        HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> (IdGhcP p -> HsExpr (GhcPass p))
-> IdGhcP p
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar (GhcPass p) -> LIdP (GhcPass p) -> HsExpr (GhcPass p)
forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar XVar (GhcPass p)
NoExtField
GHC.noExtField (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> HsExpr (GhcPass p))
-> (IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p))
-> IdGhcP p
-> HsExpr (GhcPass p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). IsPass p => IdP (GhcPass p) -> LIdP (GhcPass p)
genLocIdP @p (IdGhcP p -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> m (IdGhcP p) -> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName (GhcPass p) -> m (IdP (GhcPass p))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName (GhcPass p)
name
      HsExprVar HsName (GhcPass p)
name -> do
        HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> (IdGhcP p -> HsExpr (GhcPass p))
-> IdGhcP p
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar (GhcPass p) -> LIdP (GhcPass p) -> HsExpr (GhcPass p)
forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar XVar (GhcPass p)
NoExtField
GHC.noExtField (GenLocated (Anno (IdGhcP p)) (IdGhcP p) -> HsExpr (GhcPass p))
-> (IdGhcP p -> GenLocated (Anno (IdGhcP p)) (IdGhcP p))
-> IdGhcP p
-> HsExpr (GhcPass p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). IsPass p => IdP (GhcPass p) -> LIdP (GhcPass p)
genLocIdP @p (IdGhcP p -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> m (IdGhcP p) -> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName (GhcPass p) -> m (IdP (GhcPass p))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName (GhcPass p)
name
      HsExprApps HsExpr (GhcPass p)
f [HsExpr (GhcPass p)]
xs -> do
        f' <- HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
goExpr HsExpr (GhcPass p)
f
        xs' <- mapM goExpr xs
        pure $ foldl' (\GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
l GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
r -> HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> HsExpr (GhcPass p)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
forall (p :: Pass).
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
GHC.Compat.hsApp LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
l LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
r) (parens f') (map parens xs')
      HsExprOp HsExpr (GhcPass p)
_ HsExpr (GhcPass p)
_ HsExpr (GhcPass p)
_ ->
        String -> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
forall a. String -> a
invariantViolation String
"Compiling HsExprOp not yet supported"
      HsExprList [HsExpr (GhcPass p)]
exprs -> do
        exprs' <- (HsExpr (GhcPass p)
 -> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p))))
-> [HsExpr (GhcPass p)]
-> m [GenLocated SrcSpanAnnA (HsExpr (GhcPass p))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
HsExpr (GhcPass p)
-> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
goExpr [HsExpr (GhcPass p)]
exprs
        pure . genLoc $
          GHC.ExplicitList
            (onPsOrRn @p GHC.noAnn GHC.noExtField)
            exprs'
      HsExprRecordCon HsName (GhcPass p)
con [(HsName (GhcPass p), HsExpr (GhcPass p))]
fields -> do
        con' <- forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> XRec (GhcPass p) (ConLikeP (GhcPass p))
genLocConLikeP @p (IdGhcP p
 -> GenLocated (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
-> m (IdGhcP p)
-> m (GenLocated
        (Anno (ConLikeP (GhcPass p))) (ConLikeP (GhcPass p)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsName (GhcPass p) -> m (IdP (GhcPass p))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName (GhcPass p)
con
        fields' <- compileRecFields goExpr fields
        pure . genLoc $
          GHC.RecordCon
            (onPsOrRn @p GHC.noAnn GHC.noExtField)
            con'
            fields'
      HsExprLitString ModuleName
s -> do
        GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> m (LHsExpr (GhcPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
 -> m (LHsExpr (GhcPass p)))
-> (HsLit (GhcPass p)
    -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> HsLit (GhcPass p)
-> m (LHsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> (HsLit (GhcPass p) -> HsExpr (GhcPass p))
-> HsLit (GhcPass p)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsLit (GhcPass p) -> HsExpr (GhcPass p)
forall (p :: Pass). HsLit (GhcPass p) -> HsExpr (GhcPass p)
GHC.Compat.hsLit (HsLit (GhcPass p) -> m (LHsExpr (GhcPass p)))
-> HsLit (GhcPass p) -> m (LHsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$
          XHsString (GhcPass p) -> FastString -> HsLit (GhcPass p)
forall x. XHsString x -> FastString -> HsLit x
GHC.HsString XHsString (GhcPass p)
SourceText
GHC.SourceText.NoSourceText (ModuleName -> FastString
fsText ModuleName
s)
      HsExprLam [HsPat (GhcPass p)]
pats HsExpr (GhcPass p)
expr -> do
        pats' <- (HsPat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p))))
-> [HsPat (GhcPass p)]
-> m [GenLocated SrcSpanAnnA (Pat (GhcPass p))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsPat (GhcPass p) -> m (LPat (GhcPass p))
HsPat (GhcPass p) -> m (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsPat (GhcPass p) -> m (LPat (GhcPass p))
compileHsPat [HsPat (GhcPass p)]
pats
        expr' <- goExpr expr
        pure . genLoc . GHC.Compat.hsLamSingle $
          GHC.MG origin . genLoc $
            [ genLoc $
                GHC.Match
                  { m_ext = GHC.Compat.xMatch
                  , m_ctxt = GHC.Compat.lamAltSingle
                  , m_pats = GHC.Compat.toMatchArgs pats'
                  , m_grhss =
                      GHC.GRHSs
                        { grhssExt = GHC.emptyComments
                        , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] expr']
                        , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField
                        }
                  }
            ]
      HsExprCase HsExpr (GhcPass p)
expr [(HsPat (GhcPass p), HsExpr (GhcPass p))]
matches -> do
        expr' <- HsExpr (GhcPass p) -> m (LHsExpr (GhcPass p))
goExpr HsExpr (GhcPass p)
expr
        matches' <-
          sequence
            [ do
                pat' <- compileHsPat pat
                body' <- goExpr body
                pure . genLoc $
                  GHC.Match
                    { m_ext = GHC.Compat.xMatch
                    , m_ctxt = GHC.CaseAlt
                    , m_pats = GHC.Compat.toMatchArgs [pat']
                    , m_grhss =
                        GHC.GRHSs
                          { grhssExt = GHC.emptyComments
                          , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body']
                          , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField
                          }
                    }
            | (pat, body) <- matches
            ]
        pure
          . genLoc
          . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.CaseAlt) expr'
          $ GHC.MG origin (genLoc matches')
      HsExprData (GhcPass p)
HsExprOther ->
        String -> m (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
forall a. String -> a
invariantViolation String
"Compiling HsExprOther not supported"

    origin :: XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
origin = forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
Origin
(p ~ 'Parsed) =>
XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
GHC.FromSource XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
Origin
(p ~ 'Renamed) =>
XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
GHC.FromSource

    parens :: (IsPass p) => GHC.LHsExpr (GhcPass p) -> GHC.LHsExpr (GhcPass p)
    parens :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parens = \case
      e :: LHsExpr (GhcPass p)
e@(L SrcSpanAnnA
_ GHC.HsPar{}) -> LHsExpr (GhcPass p)
e
      e :: LHsExpr (GhcPass p)
e@(L SrcSpanAnnA
_ GHC.HsApp{}) -> HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> HsExpr (GhcPass p)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
GHC.Compat.hsPar LHsExpr (GhcPass p)
e
      e :: LHsExpr (GhcPass p)
e@(L SrcSpanAnnA
_ GHC.SectionL{}) -> HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> HsExpr (GhcPass p)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
GHC.Compat.hsPar LHsExpr (GhcPass p)
e
      e :: LHsExpr (GhcPass p)
e@(L SrcSpanAnnA
_ GHC.SectionR{}) -> HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc (HsExpr (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> HsExpr (GhcPass p)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
GHC.Compat.hsPar LHsExpr (GhcPass p)
e
      LHsExpr (GhcPass p)
e -> LHsExpr (GhcPass p)
e

{----- FastString -----}

fsText :: Text -> GHC.FastString
fsText :: ModuleName -> FastString
fsText = String -> FastString
GHC.fsLit (String -> FastString)
-> (ModuleName -> String) -> ModuleName -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
Text.unpack

{----- Utilities -----}

data GhcIdP p where
  GhcIdPs :: GHC.RdrName -> GhcIdP GhcPs
  GhcIdRn :: GHC.Name -> GhcIdP GhcRn

instance Show (GhcIdP p) where
  show :: GhcIdP p -> String
show = \case
    GhcIdPs RdrName
name -> RdrName -> String
forall a. Outputable a => a -> String
renderOutputable RdrName
name
    GhcIdRn Name
name -> Name -> String
forall a. Outputable a => a -> String
renderOutputable Name
name

instance Eq (GhcIdP p) where
  GhcIdPs RdrName
n1 == :: GhcIdP p -> GhcIdP p -> Bool
== GhcIdPs RdrName
n2 = RdrName
n1 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
n2
  GhcIdRn Name
n1 == GhcIdRn Name
n2 = Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2

unGhcIdP :: GhcIdP p -> GHC.IdP p
unGhcIdP :: forall p. GhcIdP p -> IdP p
unGhcIdP = \case
  GhcIdPs RdrName
n -> IdP p
RdrName
n
  GhcIdRn Name
n -> IdP p
Name
n

data GhcLHsExpr p where
  GhcLHsExprPs :: GHC.LHsExpr GhcPs -> GhcLHsExpr GhcPs
  GhcLHsExprRn :: GHC.LHsExpr GhcRn -> GhcLHsExpr GhcRn

instance Show (GhcLHsExpr p) where
  show :: GhcLHsExpr p -> String
show = \case
    GhcLHsExprPs LHsExpr GhcPs
e -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> String
forall a. Outputable a => a -> String
renderOutputable LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
    GhcLHsExprRn LHsExpr GhcRn
e -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> String
forall a. Outputable a => a -> String
renderOutputable LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e

unGhcLHsExpr :: GhcLHsExpr p -> GHC.LHsExpr p
unGhcLHsExpr :: forall p. GhcLHsExpr p -> LHsExpr p
unGhcLHsExpr = \case
  GhcLHsExprPs LHsExpr GhcPs
e -> LHsExpr p
LHsExpr GhcPs
e
  GhcLHsExprRn LHsExpr GhcRn
e -> LHsExpr p
LHsExpr GhcRn
e

newtype GhcFixity = GhcFixity GHC.Fixity

instance Show GhcFixity where
  show :: GhcFixity -> String
show (GhcFixity Fixity
fixity) = Fixity -> String
forall a. Outputable a => a -> String
renderOutputable Fixity
fixity

renderOutputable :: (GHC.Outputable a) => a -> String
renderOutputable :: forall a. Outputable a => a -> String
renderOutputable = SDoc -> String
GHC.showSDocUnsafe (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr

onPsOrRn :: forall p a. (IsPass p) => ((p ~ 'GHC.Parsed) => a) -> ((p ~ 'GHC.Renamed) => a) -> a
onPsOrRn :: forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn (p ~ 'Parsed) => a
ps (p ~ 'Renamed) => a
rn =
  case forall (p :: Pass). IsPass p => GhcPass p
GHC.ghcPass @p of
    GhcPass p
GhcPs -> a
(p ~ 'Parsed) => a
ps
    GhcPass p
GhcRn -> a
(p ~ 'Renamed) => a
rn
    GhcPass p
GhcTc -> String -> a
forall a. String -> a
invariantViolation String
"onPsOrRn found GhcTc"

compileRecFields ::
  forall p m arg x.
  (IsPass p, MonadCompile m (GhcPass p)) =>
  (x -> m arg)
  -> [(HsName (GhcPass p), x)]
  -> m (GHC.HsRecFields (GhcPass p) arg)
compileRecFields :: forall (p :: Pass) (m :: * -> *) arg x.
(IsPass p, MonadCompile m (GhcPass p)) =>
(x -> m arg)
-> [(HsName (GhcPass p), x)] -> m (HsRecFields (GhcPass p) arg)
compileRecFields x -> m arg
f [(HsName (GhcPass p), x)]
fields = do
  fields' <-
    [m (GenLocated
      SrcSpanAnnA
      (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc (GhcPass p))) arg))]
-> m [GenLocated
        SrcSpanAnnA
        (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc (GhcPass p))) arg)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ do
          field' <- HsName (GhcPass p) -> m (FieldOcc (GhcPass p))
compileFieldOcc HsName (GhcPass p)
field
          x' <- f x
          pure . genLoc $
            GHC.HsFieldBind
              { hfbAnn = GHC.noAnn
              , hfbLHS = genLoc field'
              , hfbRHS = x'
              , hfbPun = False
              }
      | (HsName (GhcPass p)
field, x
x) <- [(HsName (GhcPass p), x)]
fields
      ]
  pure $ GHC.Compat.mkHsRecFields fields'
  where
    compileFieldOcc :: HsName (GhcPass p) -> m (FieldOcc (GhcPass p))
compileFieldOcc HsName (GhcPass p)
field = do
      name <- HsName (GhcPass p) -> m (IdP (GhcPass p))
forall (p :: Pass) (m :: * -> *).
(IsPass p, MonadCompile m (GhcPass p)) =>
HsName (GhcPass p) -> m (IdP (GhcPass p))
compileHsName HsName (GhcPass p)
field
      pure $
        onPsOrRn @p
          GHC.FieldOcc
            { foExt = GHC.noExtField
            , foLabel = genLoc name
            }
          (GHC.Compat.fieldOccRn name)

genLocConLikeP ::
  forall p.
  (IsPass p) =>
  GHC.IdP (GhcPass p)
  -> GHC.XRec (GhcPass p) (GHC.ConLikeP (GhcPass p))
genLocConLikeP :: forall (p :: Pass).
IsPass p =>
IdP (GhcPass p) -> XRec (GhcPass p) (ConLikeP (GhcPass p))
genLocConLikeP IdP (GhcPass p)
idp = forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc IdP (GhcPass p)
RdrName
idp) (Name -> GenLocated SrcSpanAnnN Name
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc IdP (GhcPass p)
Name
idp)

genLocIdP ::
  forall p.
  (IsPass p) =>
  GHC.IdP (GhcPass p)
  -> GHC.LIdP (GhcPass p)
genLocIdP :: forall (p :: Pass). IsPass p => IdP (GhcPass p) -> LIdP (GhcPass p)
genLocIdP IdP (GhcPass p)
idp = forall (p :: Pass) a.
IsPass p =>
((p ~ 'Parsed) => a) -> ((p ~ 'Renamed) => a) -> a
onPsOrRn @p (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc IdP (GhcPass p)
RdrName
idp) (Name -> GenLocated SrcSpanAnnN Name
forall ann e. NoAnn ann => e -> GenLocated ann e
genLoc IdP (GhcPass p)
Name
idp)