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

import qualified Bag as Ghc
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 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.Hs as Ghc
import qualified GhcPlugins 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 =
  [ String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"kebab"] ((String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a. a -> ArgDescr a
Console.NoArg ((String -> Hsc String) -> ArgDescr (String -> Hsc String))
-> (String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a b. (a -> b) -> a -> b
$ String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String)
-> (String -> String) -> String -> Hsc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
kebab) String
""
  , String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"camel"] ((String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a. a -> ArgDescr a
Console.NoArg ((String -> Hsc String) -> ArgDescr (String -> Hsc String))
-> (String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a b. (a -> b) -> a -> b
$ String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String)
-> (String -> String) -> String -> Hsc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
lower) String
""
  , String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"snake"] ((String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a. a -> ArgDescr a
Console.NoArg ((String -> Hsc String) -> ArgDescr (String -> Hsc String))
-> (String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a b. (a -> b) -> a -> b
$ String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String)
-> (String -> String) -> String -> Hsc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
snake) String
""
  , String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option
    []
    [String
"strip"]
    ((String -> String -> Hsc String)
-> String -> ArgDescr (String -> Hsc String)
forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg
      (\String
prefix String
s1 -> case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
prefix String
s1 of
        Maybe String
Nothing ->
          SrcSpan -> MsgDoc -> Hsc String
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan
            (MsgDoc -> Hsc String)
-> (String -> MsgDoc) -> String -> Hsc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MsgDoc
Ghc.text
            (String -> Hsc String) -> String -> Hsc String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
prefix
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a prefix of "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s1
        Just String
s2 -> String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s2
      )
      String
"PREFIX"
    )
    String
""
  , String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"title"] ((String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a. a -> ArgDescr a
Console.NoArg ((String -> Hsc String) -> ArgDescr (String -> Hsc String))
-> (String -> Hsc String) -> ArgDescr (String -> Hsc String)
forall a b. (a -> b) -> a -> b
$ String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String)
-> (String -> String) -> String -> Hsc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
upper) String
""
  ]

-- | Applies all the monadic functions in order beginning with some starting
-- value.
applyAll :: Monad m => [a -> m a] -> a -> m a
applyAll :: [a -> m a] -> a -> m a
applyAll [a -> m a]
fs a
x = case [a -> m a]
fs of
  [] -> a -> m a
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
    [a -> m a] -> a -> m a
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 = (Char -> Char) -> String -> String
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 = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overFirst Char -> Char
Char.toLower

overFirst :: (a -> a) -> [a] -> [a]
overFirst :: (a -> a) -> [a] -> [a]
overFirst a -> a
f [a]
xs = case [a]
xs of
  a
x : [a]
ys -> a -> a
f a
x a -> [a] -> [a]
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 Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
          else Char
char Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
Char.toLower Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
        else Char
first Char -> String -> String
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 =
  SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
    (HsType GhcPs -> LHsType GhcPs)
-> (Type -> HsType GhcPs) -> Type -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
        NoExtField
XAppTy GhcPs
Ghc.noExtField
        (SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsType GhcPs -> LHsType GhcPs)
-> (RdrName -> HsType GhcPs) -> RdrName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcPs
Ghc.noExtField PromotionFlag
Ghc.NotPromoted
        (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (RdrName -> LHsType GhcPs) -> RdrName -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Ghc.Qual ModuleName
moduleName OccName
className
        )
    (LHsType GhcPs -> HsType GhcPs)
-> (Type -> LHsType GhcPs) -> Type -> HsType GhcPs
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.Located a
    loc :: a -> Located a
loc = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan

    initial :: Ghc.LHsType Ghc.GhcPs
    initial :: LHsType GhcPs
initial = HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
loc (HsType GhcPs -> LHsType GhcPs)
-> (RdrName -> HsType GhcPs) -> RdrName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcPs
ext PromotionFlag
Ghc.NotPromoted (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpan RdrName
forall a. a -> Located a
loc (RdrName -> LHsType GhcPs) -> RdrName -> LHsType GhcPs
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 =
      HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
loc (HsType GhcPs -> LHsType GhcPs)
-> (RdrName -> HsType GhcPs) -> RdrName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy NoExtField
XAppTy GhcPs
ext LHsType GhcPs
x (LHsType GhcPs -> HsType GhcPs)
-> (RdrName -> LHsType GhcPs) -> RdrName -> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
loc (HsType GhcPs -> LHsType GhcPs)
-> (RdrName -> HsType GhcPs) -> RdrName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcPs
ext PromotionFlag
Ghc.NotPromoted (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpan RdrName
forall a. a -> Located a
loc

    bare :: Ghc.LHsType Ghc.GhcPs
    bare :: LHsType GhcPs
bare = (LHsType GhcPs -> RdrName -> LHsType GhcPs)
-> LHsType GhcPs -> [RdrName] -> LHsType GhcPs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' LHsType GhcPs -> IdP GhcPs -> LHsType GhcPs
LHsType GhcPs -> RdrName -> LHsType GhcPs
combine LHsType GhcPs
initial ([RdrName] -> LHsType GhcPs) -> [RdrName] -> LHsType GhcPs
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]
_ -> HsType GhcPs -> LHsType GhcPs
forall a. a -> Located a
loc (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
Ghc.HsParTy NoExtField
XParTy GhcPs
ext 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 =
  (OccName -> LHsType GhcPs) -> [OccName] -> [LHsType GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
      (HsType GhcPs -> LHsType GhcPs)
-> (OccName -> HsType GhcPs) -> OccName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
Ghc.HsAppTy
          NoExtField
XAppTy GhcPs
Ghc.noExtField
          (SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          (HsType GhcPs -> LHsType GhcPs)
-> (RdrName -> HsType GhcPs) -> RdrName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcPs
Ghc.noExtField PromotionFlag
Ghc.NotPromoted
          (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
          (RdrName -> LHsType GhcPs) -> RdrName -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Ghc.Qual ModuleName
moduleName OccName
className
          )
      (LHsType GhcPs -> HsType GhcPs)
-> (OccName -> LHsType GhcPs) -> OccName -> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
      (HsType GhcPs -> LHsType GhcPs)
-> (OccName -> HsType GhcPs) -> OccName -> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
Ghc.HsTyVar NoExtField
XTyVar GhcPs
Ghc.noExtField PromotionFlag
Ghc.NotPromoted
      (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (OccName -> GenLocated SrcSpan RdrName)
-> OccName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
      (RdrName -> GenLocated SrcSpan RdrName)
-> (OccName -> RdrName) -> OccName -> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Ghc.Unqual
      )
    ([OccName] -> [LHsType GhcPs])
-> (Type -> [OccName]) -> Type -> [LHsType GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OccName] -> [OccName]
forall a. Eq a => [a] -> [a]
List.nub
    ([OccName] -> [OccName])
-> (Type -> [OccName]) -> Type -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> Maybe OccName) -> [Field] -> [OccName]
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
_ Located (IdP GhcPs)
lRdrName -> case GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located (IdP GhcPs)
GenLocated SrcSpan RdrName
lRdrName of
            Ghc.Unqual occName | OccName -> Bool
Ghc.isTvOcc OccName
occName -> OccName -> Maybe OccName
forall a. a -> Maybe a
Just OccName
occName
            SrcSpanLess (GenLocated SrcSpan RdrName)
_ -> Maybe OccName
forall a. Maybe a
Nothing
          HsType GhcPs
_ -> Maybe OccName
forall a. Maybe a
Nothing
        )
    ([Field] -> [OccName]) -> (Type -> [Field]) -> Type -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constructor -> [Field]) -> [Constructor] -> [Field]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
    ([Constructor] -> [Field])
-> (Type -> [Constructor]) -> Type -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Constructor]
Type.constructors

makeHsImplicitBndrs
  :: Ghc.SrcSpan
  -> Type.Type
  -> Ghc.ModuleName
  -> Ghc.OccName
  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)
makeHsImplicitBndrs :: SrcSpan
-> Type
-> ModuleName
-> OccName
-> HsImplicitBndrs GhcPs (LHsType 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 :: LHsType GhcPs
withContext = if [LHsType GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType GhcPs]
context
      then LHsType GhcPs
withoutContext
      else SrcSpan -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
        (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
Ghc.HsQualTy NoExtField
XQualTy GhcPs
Ghc.noExtField (SrcSpan -> [LHsType GhcPs] -> LHsContext GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan [LHsType GhcPs]
context) LHsType GhcPs
withoutContext
  in XHsIB GhcPs (LHsType GhcPs)
-> LHsType GhcPs -> HsImplicitBndrs GhcPs (LHsType GhcPs)
forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
Ghc.HsIB NoExtField
XHsIB GhcPs (LHsType GhcPs)
Ghc.noExtField LHsType 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 (Located (IdP GhcPs))
makeRandomVariable SrcSpan
srcSpan String
prefix = do
  Word
n <- Hsc Word
forall (m :: * -> *). MonadIO m => m Word
bumpCounter
  GenLocated SrcSpan RdrName -> Hsc (GenLocated SrcSpan RdrName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan RdrName -> Hsc (GenLocated SrcSpan RdrName))
-> (String -> GenLocated SrcSpan RdrName)
-> String
-> Hsc (GenLocated SrcSpan RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan (RdrName -> GenLocated SrcSpan RdrName)
-> (String -> RdrName) -> String -> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
Ghc.Unqual (OccName -> RdrName) -> (String -> OccName) -> String -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
Ghc.mkVarOcc (String -> Hsc (GenLocated SrcSpan RdrName))
-> String -> Hsc (GenLocated SrcSpan RdrName)
forall a b. (a -> b) -> a -> b
$ String -> String -> Word -> String
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 <- Hsc Word
forall (m :: * -> *). MonadIO m => m Word
bumpCounter
  ModuleName -> Hsc ModuleName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName -> Hsc ModuleName)
-> (String -> ModuleName) -> String -> Hsc ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
Ghc.mkModuleName (String -> Hsc ModuleName) -> String -> Hsc ModuleName
forall a b. (a -> b) -> a -> b
$ String -> String -> Word -> String
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 = (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
underscoreOne (String -> String)
-> (ModuleName -> String) -> ModuleName -> String
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 :: HsImplicitBndrs GhcPs (LHsType GhcPs)
hsImplicitBndrs = SrcSpan
-> Type
-> ModuleName
-> OccName
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
makeHsImplicitBndrs SrcSpan
srcSpan Type
type_ ModuleName
moduleName OccName
occName
  in SrcSpan
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> [LHsBind GhcPs]
-> LHsDecl GhcPs
makeLHsDecl SrcSpan
srcSpan HsImplicitBndrs GhcPs (LHsType GhcPs)
hsImplicitBndrs [LHsBind GhcPs]
lHsBinds

makeLHsDecl
  :: Ghc.SrcSpan
  -> Ghc.HsImplicitBndrs Ghc.GhcPs (Ghc.LHsType Ghc.GhcPs)
  -> [Ghc.LHsBind Ghc.GhcPs]
  -> Ghc.LHsDecl Ghc.GhcPs
makeLHsDecl :: SrcSpan
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> [LHsBind GhcPs]
-> LHsDecl GhcPs
makeLHsDecl SrcSpan
srcSpan HsImplicitBndrs GhcPs (LHsType GhcPs)
hsImplicitBndrs [LHsBind GhcPs]
lHsBinds =
  SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
    (HsDecl GhcPs -> LHsDecl GhcPs)
-> (ClsInstDecl GhcPs -> HsDecl GhcPs)
-> ClsInstDecl GhcPs
-> LHsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
Ghc.InstD NoExtField
XInstD GhcPs
Ghc.noExtField
    (InstDecl GhcPs -> HsDecl GhcPs)
-> (ClsInstDecl GhcPs -> InstDecl GhcPs)
-> ClsInstDecl GhcPs
-> HsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
Ghc.ClsInstD NoExtField
XClsInstD GhcPs
Ghc.noExtField
    (ClsInstDecl GhcPs -> LHsDecl GhcPs)
-> ClsInstDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCClsInstDecl GhcPs
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> [LTyFamInstDecl GhcPs]
-> [LDataFamInstDecl GhcPs]
-> Maybe (Located OverlapMode)
-> ClsInstDecl GhcPs
forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (Located OverlapMode)
-> ClsInstDecl pass
Ghc.ClsInstDecl
        NoExtField
XCClsInstDecl GhcPs
Ghc.noExtField
        HsImplicitBndrs GhcPs (LHsType GhcPs)
hsImplicitBndrs
        ([LHsBind GhcPs] -> LHsBinds GhcPs
forall a. [a] -> Bag a
Ghc.listToBag [LHsBind GhcPs]
lHsBinds)
        []
        []
        []
        Maybe (Located OverlapMode)
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 (MatchGroup GhcPs (LHsExpr GhcPs) -> LHsBind GhcPs)
-> (LHsExpr GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs
-> LHsBind GhcPs
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 = XMG GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Origin
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
Ghc.MG
  NoExtField
XMG GhcPs (LHsExpr GhcPs)
Ghc.noExtField
  (SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan [SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan (Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs))
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
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 =
  XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Ghc.Match
      NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
Ghc.noExtField
      (GenLocated SrcSpan RdrName
-> LexicalFixity -> SrcStrictness -> HsMatchContext RdrName
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
Ghc.FunRhs
        (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName -> GenLocated SrcSpan RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
Ghc.Unqual OccName
occName)
        LexicalFixity
Ghc.Prefix
        SrcStrictness
Ghc.NoSrcStrict
      )
      [LPat GhcPs]
lPats
    (GRHSs GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs))
-> (LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs
-> Match GhcPs (LHsExpr GhcPs)
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 =
  XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
Ghc.GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
Ghc.noExtField [SrcSpan -> LHsExpr GhcPs -> LGRHS GhcPs (LHsExpr GhcPs)
Hs.grhs SrcSpan
srcSpan LHsExpr GhcPs
hsExpr]
    (LHsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs))
-> (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs)
-> HsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan
    (HsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs))
-> HsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
Ghc.EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
Ghc.noExtField

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

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