Helpers.hs

module THLego.Helpers
where

import THLego.Prelude
import Language.Haskell.TH
import qualified TemplateHaskell.Compat.V0208 as Compat
import qualified Data.Text as Text


-- * Decs
-------------------------

typeSynonymDec :: Name -> Type -> Dec
typeSynonymDec a b =
  TySynD a [] b

recordNewtypeDec :: Name -> Name -> Type -> Dec
recordNewtypeDec _name _accessorName _type =
  NewtypeD [] _name [] Nothing _con []
  where
    _con =
      RecC _name [(_accessorName, noBang, _type)]

normalNewtypeDec :: Name -> Type -> Dec
normalNewtypeDec _name _type =
  NewtypeD [] _name [] Nothing _con []
  where
    _con =
      NormalC _name [(noBang, _type)]

recordAdtDec :: Name -> [(Name, Type)] -> Dec
recordAdtDec typeName fields =
  DataD [] typeName [] Nothing [con] []
  where
    con =
      RecC typeName (fmap (\ (fieldName, fieldType) -> (fieldName, fieldBang, fieldType)) fields)

productAdtDec :: Name -> [Type] -> Dec
productAdtDec typeName memberTypes =
  DataD [] typeName [] Nothing [con] []
  where
    con =
      NormalC typeName (fmap ((fieldBang,)) memberTypes)

sumAdtDec :: Name -> [(Name, [Type])] -> Dec
sumAdtDec a b =
  DataD [] a [] Nothing (fmap (uncurry sumCon) b) []

sumCon :: Name -> [Type] -> Con
sumCon a b =
  NormalC a (fmap (fieldBang,) b)

enumDec :: Name -> [Name] -> Dec
enumDec a b =
  DataD [] a [] Nothing (fmap (\ c -> NormalC c []) b) []


-- *
-------------------------

textName :: Text -> Name
textName =
  mkName . Text.unpack

textTyLit :: Text -> TyLit
textTyLit =
  StrTyLit . Text.unpack

noBang :: Bang
noBang =
  Bang NoSourceUnpackedness NoSourceStrictness

fieldBang :: Bang
fieldBang =
  Bang NoSourceUnpackedness SourceStrict

multiAppT :: Type -> [Type] -> Type
multiAppT base args =
  foldl' AppT base args

multiAppE :: Exp -> [Exp] -> Exp
multiAppE base args =
  foldl' AppE base args

arrowChainT :: [Type] -> Type -> Type
arrowChainT params result =
  foldr (\ a b -> AppT (AppT ArrowT a) b) result params

appliedTupleT :: [Type] -> Type
appliedTupleT a =
  foldl' AppT (TupleT (length a)) a

appliedTupleOrSingletonT :: [Type] -> Type
appliedTupleOrSingletonT =
  \ case
    [a] -> a
    a -> appliedTupleT a

appliedTupleE :: [Exp] -> Exp
appliedTupleE =
  Compat.tupE

appliedTupleOrSingletonE :: [Exp] -> Exp
appliedTupleOrSingletonE =
  \ case
    [a] -> a
    a -> appliedTupleE a

decimalIndexName :: Int -> Name
decimalIndexName =
  mkName . showChar '_' . show

alphabeticIndexName :: Int -> Name
alphabeticIndexName a =
  mkName string
  where
    string =
      showIntAtBase 26 (chr . (+) 97) a ""

enumAlphabeticNames :: Int -> [Name]
enumAlphabeticNames =
  fmap alphabeticIndexName . enumFromTo 0 . pred

{-|
Map every element of a list with a new name.
-}
{-# INLINE mapWithAlphabeticName #-}
mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName f list =
  foldr step (const []) list 0
  where
    step a next !index =
      f (alphabeticIndexName index) a : next (succ index)

aName :: Name
aName =
  mkName "a"

bName :: Name
bName =
  mkName "b"

cName :: Name
cName =
  mkName "c"

eqConstraintT :: Name -> Type -> Type
eqConstraintT name =
  AppT (AppT EqualityT (VarT name))