module Evoke.Generator.Common
  ( Generator,
    applyAll,
    fieldNameOptions,
    makeInstanceDeclaration,
    makeLHsBind,
    makeRandomModule,
    makeRandomVariable,
  )
where

import qualified Control.Monad.IO.Class as IO
import qualified Data.Char as Char
import qualified Data.IORef as IORef
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Evoke.Hs as Hs
import qualified Evoke.Hsc as Hsc
import qualified Evoke.Type.Constructor as Constructor
import qualified Evoke.Type.Field as Field
import qualified Evoke.Type.Type as Type
import qualified GHC.Data.Bag as Ghc
import qualified GHC.Hs as Ghc
import qualified GHC.Plugins as Ghc
import qualified GHC.Types.Fixity as Ghc
import qualified System.Console.GetOpt as Console
import qualified System.IO.Unsafe as Unsafe
import qualified Text.Printf as Printf

type Generator =
  Ghc.ModuleName ->
  Ghc.LIdP Ghc.GhcPs ->
  Ghc.LHsQTyVars Ghc.GhcPs ->
  [Ghc.LConDecl Ghc.GhcPs] ->
  [String] ->
  Ghc.SrcSpan ->
  Ghc.Hsc
    ([Ghc.LImportDecl Ghc.GhcPs], [Ghc.LHsDecl Ghc.GhcPs])

fieldNameOptions ::
  Ghc.SrcSpan -> [Console.OptDescr (String -> Ghc.Hsc String)]
fieldNameOptions :: SrcSpan -> [OptDescr (String -> Hsc String)]
fieldNameOptions SrcSpan
srcSpan =
  [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"kebab"] (forall a. a -> ArgDescr a
Console.NoArg forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
kebab) String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"camel"] (forall a. a -> ArgDescr a
Console.NoArg forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
lower) String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"snake"] (forall a. a -> ArgDescr a
Console.NoArg forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
snake) String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"prefix", String
"strip"] (forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg (SrcSpan -> String -> String -> Hsc String
stripPrefix SrcSpan
srcSpan) String
"PREFIX") String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"suffix"] (forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg (SrcSpan -> String -> String -> Hsc String
stripSuffix SrcSpan
srcSpan) String
"SUFFIX") String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"title"] (forall a. a -> ArgDescr a
Console.NoArg forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
upper) String
"",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"rename"] (forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg (SrcSpan -> String -> String -> Hsc String
rename SrcSpan
srcSpan) String
"OLD:NEW") String
""
  ]

stripPrefix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String
stripPrefix :: SrcSpan -> String -> String -> Hsc String
stripPrefix SrcSpan
srcSpan String
prefix String
s1 = case forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
prefix String
s1 of
  Maybe String
Nothing ->
    forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
Ghc.text
      forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
prefix
        forall a. Semigroup a => a -> a -> a
<> String
" is not a prefix of "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
s1
  Just String
s2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s2

stripSuffix :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String
stripSuffix :: SrcSpan -> String -> String -> Hsc String
stripSuffix SrcSpan
srcSpan String
suffix String
s1 = case Text -> Text -> Maybe Text
Text.stripSuffix (String -> Text
Text.pack String
suffix) (String -> Text
Text.pack String
s1) of
  Maybe Text
Nothing ->
    forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
Ghc.text
      forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
suffix
        forall a. Semigroup a => a -> a -> a
<> String
" is not a suffix of "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
s1
  Just Text
s2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
s2

rename :: Ghc.SrcSpan -> String -> String -> Ghc.Hsc String
rename :: SrcSpan -> String -> String -> Hsc String
rename SrcSpan
loc String
arg String
str =
  case Text -> Text -> [Text]
Text.splitOn (Char -> Text
Text.singleton Char
':') forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
arg of
    [Text
old, Text
new]
      | Bool -> Bool
not (Text -> Bool
Text.null Text
old Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
new) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            if String -> Text
Text.pack String
str forall a. Eq a => a -> a -> Bool
== Text
old
              then Text -> String
Text.unpack Text
new
              else String
str
    [Text]
_ -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
Ghc.text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
arg forall a. Semigroup a => a -> a -> a
<> String
" is invalid"

-- | Applies all the monadic functions in order beginning with some starting
-- value.
applyAll :: Monad m => [a -> m a] -> a -> m a
applyAll :: forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
applyAll [a -> m a]
fs a
x = case [a -> m a]
fs of
  [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  a -> m a
f : [a -> m a]
gs -> do
    a
y <- a -> m a
f a
x
    forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
applyAll [a -> m a]
gs a
y

-- | Converts the first character into upper case.
upper :: String -> String
upper :: String -> String
upper = forall a. (a -> a) -> [a] -> [a]
overFirst Char -> Char
Char.toUpper

-- | Converts the first character into lower case.
lower :: String -> String
lower :: String -> String
lower = forall a. (a -> a) -> [a] -> [a]
overFirst Char -> Char
Char.toLower

overFirst :: (a -> a) -> [a] -> [a]
overFirst :: forall a. (a -> a) -> [a] -> [a]
overFirst a -> a
f [a]
xs = case [a]
xs of
  a
x : [a]
ys -> a -> a
f a
x forall a. a -> [a] -> [a]
: [a]
ys
  [a]
_ -> [a]
xs

-- | Converts the string into kebab case.
--
-- >>> kebab "DoReMi"
-- "do-re-mi"
kebab :: String -> String
kebab :: String -> String
kebab = Char -> String -> String
camelTo Char
'-'

-- | Converts the string into snake case.
--
-- >>> snake "DoReMi"
-- "do_re_mi"
snake :: String -> String
snake :: String -> String
snake = Char -> String -> String
camelTo Char
'_'

camelTo :: Char -> String -> String
camelTo :: Char -> String -> String
camelTo Char
char =
  let go :: Bool -> String -> String
go Bool
wasUpper String
string = case String
string of
        String
"" -> String
""
        Char
first : String
rest ->
          if Char -> Bool
Char.isUpper Char
first
            then
              if Bool
wasUpper
                then Char -> Char
Char.toLower Char
first forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
                else Char
char forall a. a -> [a] -> [a]
: Char -> Char
Char.toLower Char
first forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
            else Char
first forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
False String
rest
   in Bool -> String -> String
go Bool
True

makeLHsType ::
  Ghc.SrcSpan ->
  Ghc.ModuleName ->
  Ghc.OccName ->
  Type.Type ->
  Ghc.LHsType Ghc.GhcPs
makeLHsType :: SrcSpan -> ModuleName -> OccName -> Type -> LHsType GhcPs
makeLHsType SrcSpan
srcSpan ModuleName
moduleName OccName
className =
  forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
      NoExtField
Ghc.noExtField
      ( forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Ghc.Qual ModuleName
moduleName OccName
className
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Type -> LHsType GhcPs
toLHsType SrcSpan
srcSpan

toLHsType :: Ghc.SrcSpan -> Type.Type -> Ghc.LHsType Ghc.GhcPs
toLHsType :: SrcSpan -> Type -> LHsType GhcPs
toLHsType SrcSpan
srcSpan Type
type_ =
  let ext :: Ghc.NoExtField
      ext :: NoExtField
ext = NoExtField
Ghc.noExtField

      loc :: a -> Ghc.LocatedAn b a
      loc :: forall a b. a -> LocatedAn b a
loc = forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan

      initial :: Ghc.LHsType Ghc.GhcPs
      initial :: LHsType GhcPs
initial = forall a b. a -> LocatedAn b a
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> LocatedAn b a
loc forall a b. (a -> b) -> a -> b
$ Type -> IdP GhcPs
Type.name Type
type_

      combine ::
        Ghc.LHsType Ghc.GhcPs -> Ghc.IdP Ghc.GhcPs -> Ghc.LHsType Ghc.GhcPs
      combine :: LHsType GhcPs -> IdP GhcPs -> LHsType GhcPs
combine LHsType GhcPs
x =
        forall a b. a -> LocatedAn b a
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy NoExtField
ext LHsType GhcPs
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> LocatedAn b a
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> LocatedAn b a
loc

      bare :: Ghc.LHsType Ghc.GhcPs
      bare :: LHsType GhcPs
bare = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' LHsType GhcPs -> IdP GhcPs -> LHsType GhcPs
combine LHsType GhcPs
initial forall a b. (a -> b) -> a -> b
$ Type -> [IdP GhcPs]
Type.variables Type
type_
   in case Type -> [IdP GhcPs]
Type.variables Type
type_ of
        [] -> LHsType GhcPs
bare
        [IdP GhcPs]
_ -> forall a b. a -> LocatedAn b a
loc forall a b. (a -> b) -> a -> b
$ forall pass. XParTy pass -> LHsType pass -> HsType pass
Ghc.HsParTy forall a. EpAnn a
Ghc.noAnn LHsType GhcPs
bare

makeHsContext ::
  Ghc.SrcSpan ->
  Ghc.ModuleName ->
  Ghc.OccName ->
  Type.Type ->
  [Ghc.LHsType Ghc.GhcPs]
makeHsContext :: SrcSpan -> ModuleName -> OccName -> Type -> [LHsType GhcPs]
makeHsContext SrcSpan
srcSpan ModuleName
moduleName OccName
className =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
          NoExtField
Ghc.noExtField
          ( forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
              forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Ghc.Qual ModuleName
moduleName OccName
className
          )
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
Ghc.HsTyVar forall a. EpAnn a
Ghc.noAnn PromotionFlag
Ghc.NotPromoted
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Ghc.Unqual
    )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
List.nub
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
      ( \Field
field -> case Field -> HsType GhcPs
Field.type_ Field
field of
          Ghc.HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
lRdrName -> case forall l e. GenLocated l e -> e
Ghc.unLoc LIdP GhcPs
lRdrName of
            Ghc.Unqual OccName
occName | OccName -> Bool
Ghc.isTvOcc OccName
occName -> forall a. a -> Maybe a
Just OccName
occName
            RdrName
_ -> forall a. Maybe a
Nothing
          HsType GhcPs
_ -> forall a. Maybe a
Nothing
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Constructor]
Type.constructors

makeHsImplicitBndrs ::
  Ghc.SrcSpan ->
  Type.Type ->
  Ghc.ModuleName ->
  Ghc.OccName ->
  Ghc.LHsSigType Ghc.GhcPs
makeHsImplicitBndrs :: SrcSpan -> Type -> ModuleName -> OccName -> LHsSigType GhcPs
makeHsImplicitBndrs SrcSpan
srcSpan Type
type_ ModuleName
moduleName OccName
className =
  let withoutContext :: LHsType GhcPs
withoutContext = SrcSpan -> ModuleName -> OccName -> Type -> LHsType GhcPs
makeLHsType SrcSpan
srcSpan ModuleName
moduleName OccName
className Type
type_
      context :: [LHsType GhcPs]
context = SrcSpan -> ModuleName -> OccName -> Type -> [LHsType GhcPs]
makeHsContext SrcSpan
srcSpan ModuleName
moduleName OccName
className Type
type_
      withContext :: LocatedAn AnnListItem (HsType GhcPs)
withContext =
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedAn AnnListItem (HsType GhcPs)]
context
          then LocatedAn AnnListItem (HsType GhcPs)
withoutContext
          else
            forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$
              forall pass.
XQualTy pass
-> Maybe (LHsContext pass) -> LHsType pass -> HsType pass
Ghc.HsQualTy NoExtField
Ghc.noExtField (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan [LocatedAn AnnListItem (HsType GhcPs)]
context) LocatedAn AnnListItem (HsType GhcPs)
withoutContext
   in forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
Ghc.HsSig NoExtField
Ghc.noExtField forall flag. HsOuterTyVarBndrs flag GhcPs
Ghc.mkHsOuterImplicit LocatedAn AnnListItem (HsType GhcPs)
withContext

-- | Makes a random variable name using the given prefix.
makeRandomVariable :: Ghc.SrcSpan -> String -> Ghc.Hsc (Ghc.LIdP Ghc.GhcPs)
makeRandomVariable :: SrcSpan -> String -> Hsc (LIdP GhcPs)
makeRandomVariable SrcSpan
srcSpan String
prefix = do
  Word
n <- forall (m :: * -> *). MonadIO m => m Word
bumpCounter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Ghc.Unqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
Ghc.mkVarOcc forall a b. (a -> b) -> a -> b
$
    forall r. PrintfType r => String -> r
Printf.printf
      String
"%s%d"
      String
prefix
      Word
n

-- | Makes a random module name. This will convert any periods to underscores
-- and add a unique suffix.
--
-- >>> makeRandomModule "Data.Aeson"
-- "Data_Aeson_1"
makeRandomModule :: Ghc.ModuleName -> Ghc.Hsc Ghc.ModuleName
makeRandomModule :: ModuleName -> Hsc ModuleName
makeRandomModule ModuleName
moduleName = do
  Word
n <- forall (m :: * -> *). MonadIO m => m Word
bumpCounter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
Ghc.mkModuleName forall a b. (a -> b) -> a -> b
$
    forall r. PrintfType r => String -> r
Printf.printf
      String
"%s_%d"
      (ModuleName -> String
underscoreAll ModuleName
moduleName)
      Word
n

underscoreAll :: Ghc.ModuleName -> String
underscoreAll :: ModuleName -> String
underscoreAll = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
underscoreOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
Ghc.moduleNameString

underscoreOne :: Char -> Char
underscoreOne :: Char -> Char
underscoreOne Char
c = case Char
c of
  Char
'.' -> Char
'_'
  Char
_ -> Char
c

makeInstanceDeclaration ::
  Ghc.SrcSpan ->
  Type.Type ->
  Ghc.ModuleName ->
  Ghc.OccName ->
  [Ghc.LHsBind Ghc.GhcPs] ->
  Ghc.LHsDecl Ghc.GhcPs
makeInstanceDeclaration :: SrcSpan
-> Type
-> ModuleName
-> OccName
-> [LHsBind GhcPs]
-> LHsDecl GhcPs
makeInstanceDeclaration SrcSpan
srcSpan Type
type_ ModuleName
moduleName OccName
occName [LHsBind GhcPs]
lHsBinds =
  let hsImplicitBndrs :: LHsSigType GhcPs
hsImplicitBndrs = SrcSpan -> Type -> ModuleName -> OccName -> LHsSigType GhcPs
makeHsImplicitBndrs SrcSpan
srcSpan Type
type_ ModuleName
moduleName OccName
occName
   in SrcSpan -> LHsSigType GhcPs -> [LHsBind GhcPs] -> LHsDecl GhcPs
makeLHsDecl SrcSpan
srcSpan GenLocated SrcSpanAnnA (HsSigType GhcPs)
hsImplicitBndrs [LHsBind GhcPs]
lHsBinds

makeLHsDecl ::
  Ghc.SrcSpan ->
  Ghc.LHsSigType Ghc.GhcPs ->
  [Ghc.LHsBind Ghc.GhcPs] ->
  Ghc.LHsDecl Ghc.GhcPs
makeLHsDecl :: SrcSpan -> LHsSigType GhcPs -> [LHsBind GhcPs] -> LHsDecl GhcPs
makeLHsDecl SrcSpan
srcSpan LHsSigType GhcPs
hsImplicitBndrs [LHsBind GhcPs]
lHsBinds =
  forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XInstD p -> InstDecl p -> HsDecl p
Ghc.InstD NoExtField
Ghc.noExtField
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
Ghc.ClsInstD NoExtField
Ghc.noExtField
    forall a b. (a -> b) -> a -> b
$ forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (XRec pass OverlapMode)
-> ClsInstDecl pass
Ghc.ClsInstDecl
      (forall a. EpAnn a
Ghc.noAnn, AnnSortKey
Ghc.NoAnnSortKey)
      LHsSigType GhcPs
hsImplicitBndrs
      (forall a. [a] -> Bag a
Ghc.listToBag [LHsBind GhcPs]
lHsBinds)
      []
      []
      []
      forall a. Maybe a
Nothing

makeLHsBind ::
  Ghc.SrcSpan ->
  Ghc.OccName ->
  [Ghc.LPat Ghc.GhcPs] ->
  Ghc.LHsExpr Ghc.GhcPs ->
  Ghc.LHsBind Ghc.GhcPs
makeLHsBind :: SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
makeLHsBind SrcSpan
srcSpan OccName
occName [LPat GhcPs]
pats =
  SrcSpan
-> OccName -> MatchGroup GhcPs (LHsExpr GhcPs) -> LHsBind GhcPs
Hs.funBind SrcSpan
srcSpan OccName
occName forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> OccName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
makeMatchGroup SrcSpan
srcSpan OccName
occName [LPat GhcPs]
pats

makeMatchGroup ::
  Ghc.SrcSpan ->
  Ghc.OccName ->
  [Ghc.LPat Ghc.GhcPs] ->
  Ghc.LHsExpr Ghc.GhcPs ->
  Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
makeMatchGroup :: SrcSpan
-> OccName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
makeMatchGroup SrcSpan
srcSpan OccName
occName [LPat GhcPs]
lPats LHsExpr GhcPs
hsExpr =
  forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
Ghc.MG
    NoExtField
Ghc.noExtField
    (forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan [forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ SrcSpan
-> OccName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Match GhcPs (LHsExpr GhcPs)
makeMatch SrcSpan
srcSpan OccName
occName [LPat GhcPs]
lPats LHsExpr GhcPs
hsExpr])
    Origin
Ghc.Generated

makeMatch ::
  Ghc.SrcSpan ->
  Ghc.OccName ->
  [Ghc.LPat Ghc.GhcPs] ->
  Ghc.LHsExpr Ghc.GhcPs ->
  Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
makeMatch :: SrcSpan
-> OccName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Match GhcPs (LHsExpr GhcPs)
makeMatch SrcSpan
srcSpan OccName
occName [LPat GhcPs]
lPats =
  forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Ghc.Match
    forall a. EpAnn a
Ghc.noAnn
    ( forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
Ghc.FunRhs
        (forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
Ghc.Unqual OccName
occName)
        LexicalFixity
Ghc.Prefix
        SrcStrictness
Ghc.NoSrcStrict
    )
    [LPat GhcPs]
lPats
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
makeGRHSs SrcSpan
srcSpan

makeGRHSs ::
  Ghc.SrcSpan ->
  Ghc.LHsExpr Ghc.GhcPs ->
  Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
makeGRHSs :: SrcSpan -> LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
makeGRHSs SrcSpan
srcSpan LHsExpr GhcPs
hsExpr =
  forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
Ghc.GRHSs EpAnnComments
Ghc.emptyComments [SrcSpan -> LHsExpr GhcPs -> LGRHS GhcPs (LHsExpr GhcPs)
Hs.grhs SrcSpan
srcSpan LHsExpr GhcPs
hsExpr] forall a b. (a -> b) -> a -> b
$
    forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
Ghc.EmptyLocalBinds NoExtField
Ghc.noExtField

bumpCounter :: IO.MonadIO m => m Word
bumpCounter :: forall (m :: * -> *). MonadIO m => m Word
bumpCounter = forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef Word
counterRef forall a b. (a -> b) -> a -> b
$ \Word
n -> (Word
n forall a. Num a => a -> a -> a
+ Word
1, Word
n)

counterRef :: IORef.IORef Word
counterRef :: IORef Word
counterRef = forall a. IO a -> a
Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
IORef.newIORef Word
0
{-# NOINLINE counterRef #-}