module THLego.Helpers where
import qualified Data.Text as Text
import Language.Haskell.TH.Syntax
import THLego.Prelude
import qualified TemplateHaskell.Compat.V0208 as Compat
typeSynonymDec :: Name -> Type -> Dec
typeSynonymDec :: Name -> Type -> Dec
typeSynonymDec Name
a Type
b =
Name -> [TyVarBndr] -> Type -> Dec
TySynD Name
a [] Type
b
recordNewtypeDec :: Name -> Name -> Type -> Dec
recordNewtypeDec :: Name -> Name -> Type -> Dec
recordNewtypeDec Name
_name Name
_accessorName Type
_type =
Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD [] Name
_name [] Maybe Type
forall a. Maybe a
Nothing Con
_con []
where
_con :: Con
_con =
Name -> [VarBangType] -> Con
RecC Name
_name [(Name
_accessorName, Bang
noBang, Type
_type)]
normalNewtypeDec :: Name -> Type -> Dec
normalNewtypeDec :: Name -> Type -> Dec
normalNewtypeDec Name
_name Type
_type =
Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD [] Name
_name [] Maybe Type
forall a. Maybe a
Nothing Con
_con []
where
_con :: Con
_con =
Name -> [BangType] -> Con
NormalC Name
_name [(Bang
noBang, Type
_type)]
recordAdtDec :: Name -> [(Name, Type)] -> Dec
recordAdtDec :: Name -> [(Name, Type)] -> Dec
recordAdtDec Name
typeName [(Name, Type)]
fields =
Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
typeName [] Maybe Type
forall a. Maybe a
Nothing [Con
con] []
where
con :: Con
con =
Name -> [VarBangType] -> Con
RecC Name
typeName (((Name, Type) -> VarBangType) -> [(Name, Type)] -> [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
fieldName, Type
fieldType) -> (Name
fieldName, Bang
fieldBang, Type
fieldType)) [(Name, Type)]
fields)
productAdtDec :: Name -> [Type] -> Dec
productAdtDec :: Name -> Cxt -> Dec
productAdtDec Name
typeName Cxt
memberTypes =
Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
typeName [] Maybe Type
forall a. Maybe a
Nothing [Con
con] []
where
con :: Con
con =
Name -> [BangType] -> Con
NormalC Name
typeName ((Type -> BangType) -> Cxt -> [BangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Bang
fieldBang,)) Cxt
memberTypes)
sumAdtDec :: Name -> [(Name, [Type])] -> Dec
sumAdtDec :: Name -> [(Name, Cxt)] -> Dec
sumAdtDec Name
a [(Name, Cxt)]
b =
Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
a [] Maybe Type
forall a. Maybe a
Nothing (((Name, Cxt) -> Con) -> [(Name, Cxt)] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Cxt -> Con) -> (Name, Cxt) -> Con
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Cxt -> Con
sumCon) [(Name, Cxt)]
b) []
sumCon :: Name -> [Type] -> Con
sumCon :: Name -> Cxt -> Con
sumCon Name
a Cxt
b =
Name -> [BangType] -> Con
NormalC Name
a ((Type -> BangType) -> Cxt -> [BangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bang
fieldBang,) Cxt
b)
enumDec :: Name -> [Name] -> Dec
enumDec :: Name -> [Name] -> Dec
enumDec Name
a [Name]
b =
Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
a [] Maybe Type
forall a. Maybe a
Nothing ((Name -> Con) -> [Name] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
c -> Name -> [BangType] -> Con
NormalC Name
c []) [Name]
b) []
textName :: Text -> Name
textName :: Text -> Name
textName =
String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack
textTyLit :: Text -> TyLit
textTyLit :: Text -> TyLit
textTyLit =
String -> TyLit
StrTyLit (String -> TyLit) -> (Text -> String) -> Text -> TyLit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack
noBang :: Bang
noBang :: Bang
noBang =
SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
fieldBang :: Bang
fieldBang :: Bang
fieldBang =
SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict
multiAppT :: Type -> [Type] -> Type
multiAppT :: Type -> Cxt -> Type
multiAppT Type
base Cxt
args =
(Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT Type
base Cxt
args
multiAppE :: Exp -> [Exp] -> Exp
multiAppE :: Exp -> [Exp] -> Exp
multiAppE Exp
base [Exp]
args =
(Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
base [Exp]
args
arrowChainT :: [Type] -> Type -> Type
arrowChainT :: Cxt -> Type -> Type
arrowChainT Cxt
params Type
result =
(Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
a Type
b -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
a) Type
b) Type
result Cxt
params
appliedTupleT :: [Type] -> Type
appliedTupleT :: Cxt -> Type
appliedTupleT Cxt
a =
(Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
a)) Cxt
a
appliedTupleOrSingletonT :: [Type] -> Type
appliedTupleOrSingletonT :: Cxt -> Type
appliedTupleOrSingletonT =
\case
[Type
a] -> Type
a
Cxt
a -> Cxt -> Type
appliedTupleT Cxt
a
appliedTupleE :: [Exp] -> Exp
appliedTupleE :: [Exp] -> Exp
appliedTupleE =
[Exp] -> Exp
Compat.tupE
appliedTupleOrSingletonE :: [Exp] -> Exp
appliedTupleOrSingletonE :: [Exp] -> Exp
appliedTupleOrSingletonE =
\case
[Exp
a] -> Exp
a
[Exp]
a -> [Exp] -> Exp
appliedTupleE [Exp]
a
nameString :: Name -> String
nameString :: Name -> String
nameString (Name (OccName String
x) NameFlavour
_) =
String
x
decimalIndexName :: Int -> Name
decimalIndexName :: Int -> Name
decimalIndexName =
String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> ShowS
showChar Char
'_' ShowS -> (Int -> String) -> Int -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> String
forall a. Show a => a -> String
show
alphabeticIndexName :: Int -> Name
alphabeticIndexName :: Int -> Name
alphabeticIndexName Int
a =
String -> Name
mkName String
string
where
string :: String
string =
Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
26 (Int -> Char
chr (Int -> Char) -> (Int -> Int) -> Int -> Char
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
97) Int
a String
""
enumAlphabeticNames :: Int -> [Name]
enumAlphabeticNames :: Int -> [Name]
enumAlphabeticNames =
(Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName ([Int] -> [Name]) -> (Int -> [Int]) -> Int -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> [Int]) -> (Int -> Int) -> Int -> [Int]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int
forall a. Enum a => a -> a
pred
{-# INLINE mapWithAlphabeticName #-}
mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName Name -> a -> b
f [a]
list =
(a -> (Int -> [b]) -> Int -> [b])
-> (Int -> [b]) -> [a] -> Int -> [b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (Int -> [b]) -> Int -> [b]
step ([b] -> Int -> [b]
forall a b. a -> b -> a
const []) [a]
list Int
0
where
step :: a -> (Int -> [b]) -> Int -> [b]
step a
a Int -> [b]
next !Int
index =
Name -> a -> b
f (Int -> Name
alphabeticIndexName Int
index) a
a b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Int -> [b]
next (Int -> Int
forall a. Enum a => a -> a
succ Int
index)
aName :: Name
aName :: Name
aName =
String -> Name
mkName String
"a"
bName :: Name
bName :: Name
bName =
String -> Name
mkName String
"b"
cName :: Name
cName :: Name
cName =
String -> Name
mkName String
"c"
eqConstraintT :: Name -> Type -> Type
eqConstraintT :: Name -> Type -> Type
eqConstraintT Name
name =
Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
EqualityT (Name -> Type
VarT Name
name))
applicativeChainE :: Exp -> [Exp] -> Exp
applicativeChainE :: Exp -> [Exp] -> Exp
applicativeChainE Exp
mappingE [Exp]
apEList =
case [Exp]
apEList of
Exp
h : [Exp]
t ->
Exp -> NonEmpty Exp -> Exp
intersperseInfixE
(Name -> Exp
VarE '(<*>))
(Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
mappingE) (Name -> Exp
VarE '(<$>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
h) Exp -> [Exp] -> NonEmpty Exp
forall a. a -> [a] -> NonEmpty a
:| [Exp]
t)
[Exp]
_ ->
Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) Exp
mappingE
intersperseInfixE :: Exp -> NonEmpty Exp -> Exp
intersperseInfixE :: Exp -> NonEmpty Exp -> Exp
intersperseInfixE Exp
op =
(Exp -> Exp -> Exp) -> NonEmpty Exp -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Exp
l Exp
r -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
l) Exp
op (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
r))
textLitE :: Text -> Exp
textLitE :: Text -> Exp
textLitE =
Lit -> Exp
LitE (Lit -> Exp) -> (Text -> Lit) -> Text -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lit
StringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack