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

-- * Decs

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 [] 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 [] 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 [] forall a. Maybe a
Nothing [Con
con] []
  where
    con :: Con
con =
      Name -> [VarBangType] -> Con
RecC Name
typeName (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 [] forall a. Maybe a
Nothing [Con
con] []
  where
    con :: Con
con =
      Name -> [BangType] -> Con
NormalC Name
typeName (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 [] forall a. Maybe a
Nothing (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (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 [] forall a. Maybe a
Nothing (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 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 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 =
  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 =
  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 =
  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 =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT (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 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
'_' forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 =
      forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
26 (Int -> Char
chr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Num a => a -> a -> a
(+) Int
97) Int
a String
""

enumAlphabeticNames :: Int -> [Name]
enumAlphabeticNames :: Int -> [Name]
enumAlphabeticNames =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Name
alphabeticIndexName forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Enum a => a -> a
pred

-- |
-- Map every element of a list with a new name.
{-# INLINE mapWithAlphabeticName #-}
mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName :: forall a b. (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName Name -> a -> b
f [a]
list =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (Int -> [b]) -> Int -> [b]
step (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 forall a. a -> [a] -> [a]
: Int -> [b]
next (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 (forall a. a -> Maybe a
Just Exp
mappingE) (Name -> Exp
VarE '(<$>)) (forall a. a -> Maybe a
Just Exp
h) 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 =
  forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Exp
l Exp
r -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
l) Exp
op (forall a. a -> Maybe a
Just Exp
r))

textLitE :: Text -> Exp
textLitE :: Text -> Exp
textLitE =
  Lit -> Exp
LitE 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 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