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 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.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
"prefix", String
"strip"] ((String -> String -> Hsc String)
-> String -> ArgDescr (String -> Hsc String)
forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg (SrcSpan -> String -> String -> Hsc String
stripPrefix SrcSpan
srcSpan) 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
"suffix"] ((String -> String -> Hsc String)
-> String -> ArgDescr (String -> Hsc String)
forall a. (String -> a) -> String -> ArgDescr a
Console.ReqArg (SrcSpan -> String -> String -> Hsc String
stripSuffix SrcSpan
srcSpan) String
"SUFFIX" ) 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
""
, String
-> [String]
-> ArgDescr (String -> Hsc String)
-> String
-> OptDescr (String -> Hsc String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Console.Option [] [String
"rename"] ((String -> String -> Hsc String)
-> String -> ArgDescr (String -> Hsc String)
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 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
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 ->
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
suffix
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a suffix of "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s1
Just Text
s2 -> String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String) -> String -> Hsc String
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
':') (Text -> [Text]) -> Text -> [Text]
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) ->
String -> Hsc String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Hsc String) -> String -> Hsc String
forall a b. (a -> b) -> a -> b
$ if String -> Text
Text.pack String
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
old
then Text -> String
Text.unpack Text
new
else String
str
[Text]
_ -> SrcSpan -> MsgDoc -> Hsc String
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
loc (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
arg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is invalid"
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
upper :: String -> String
upper :: String -> String
upper = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overFirst Char -> Char
Char.toUpper
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
kebab :: String -> String
kebab :: String -> String
kebab = Char -> String -> String
camelTo Char
'-'
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
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
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 #-}