    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE TemplateHaskell #-}

    -- |
    --
    -- Module      : SDL.Raw.Helper
    -- Copyright   : (c) 2015 Siniša Biđin, 2021 Daniel Firth
    -- License     : MIT
    -- Maintainer  : sinisa@bidin.eu, dan.firth@homotopic.tech
    -- Stability   : experimental
    --
    -- Exposes a way to automatically generate a foreign import alongside its lifted,
    -- inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules.
    module SDL.Raw.Helper (liftF) where

    import Control.Monad (replicateM)
    import Control.Monad.IO.Class (MonadIO, liftIO)
    import Language.Haskell.TH
      ( Body (NormalB),
        Callconv (CCall),
        Clause (Clause),
        Dec (ForeignD, FunD, PragmaD, SigD),
        Exp (AppE, VarE),
        Foreign (ImportF),
        Inline (Inline),
        Name,
        Pat (VarP),
        Phases (AllPhases),
        Pragma (InlineP),
        Q,
        RuleMatch (FunLike),
        Safety (Safe),
        TyVarBndr (PlainTV),
        Type (AppT, ArrowT, ConT, ForallT, SigT, VarT),
        mkName,
        newName,
    #if MIN_VERSION_template_haskell(2,17,0)
        Specificity(SpecifiedSpec)
    #endif
      )

    -- | Given a name @fname@, a name of a C function @cname@ and the desired
    -- Haskell type @ftype@, this function generates:
    --
    -- * A foreign import of @cname@, named as @fname'@.
    -- * An always-inline MonadIO version of @fname'@, named @fname@.
    liftF :: String -> String -> Q Type -> Q [Dec]
    liftF :: String -> String -> Q Type -> Q [Dec]
    liftF String
    fname String
    cname Q Type
    ftype = do
      let f' :: Name
    f' = String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    fname String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'" -- Direct binding.
      let f :: Name
    f = String -> Name
    mkName String
    fname -- Lifted.
      t' <- Q Type
    ftype -- Type of direct binding.

      -- The generated function accepts n arguments.
      args <- replicateM (countArgs t') $ newName "x"

      -- If the function has no arguments, then we just liftIO it directly.
      -- However, this fails to typecheck without an explicit type signature.
      -- Therefore, we include one. TODO: Can we get rid of this?
      sigd <- case args of
        [] -> ((Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    : []) (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Type -> Dec
    SigD Name
    f) (Type -> [Dec]) -> Q Type -> Q [Dec]
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Type -> Q Type
    liftType Type
    t'
        [Name]
    _ -> [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

      return $
        concat
          [ [ ForeignD $ ImportF CCall Safe cname f' t',
              PragmaD $ InlineP f Inline FunLike AllPhases
            ],
            sigd,
            [ FunD
                f
                [ Clause
                    (map VarP args)
                    (NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args])
                    []
                ]
            ]
          ]

    -- | How many arguments does a function of a given type take?
    countArgs :: Type -> Int
    countArgs :: Type -> Int
    countArgs = Int -> Type -> Int
    forall p. Num p => p -> Type -> p
    count Int
    0
      where
        count :: Num p => p -> Type -> p
        count :: forall p. Num p => p -> Type -> p
    count !p
    n = \case
          (AppT (AppT Type
    ArrowT Type
    _) Type
    t) -> p -> Type -> p
    forall p. Num p => p -> Type -> p
    count (p
    n p -> p -> p
    forall a. Num a => a -> a -> a
    + p
    1) Type
    t
          (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t) -> p -> Type -> p
    forall p. Num p => p -> Type -> p
    count p
    n Type
    t
          (SigT Type
    t Type
    _) -> p -> Type -> p
    forall p. Num p => p -> Type -> p
    count p
    n Type
    t
          Type
    _ -> p
    n

    -- | An expression where f is applied to n arguments.
    applyTo :: Name -> [Exp] -> Exp
    applyTo :: Name -> [Exp] -> Exp
    applyTo Name
    f [] = Name -> Exp
    VarE Name
    f
    applyTo Name
    f [Exp]
    es = [Exp] -> Exp -> Exp
    forall (t :: * -> *). Foldable t => t Exp -> Exp -> Exp
    loop ([Exp] -> [Exp]
    forall a. HasCallStack => [a] -> [a]
    tail [Exp]
    es) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    f) (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $ [Exp] -> Exp
    forall a. HasCallStack => [a] -> a
    head [Exp]
    es
      where
        loop :: Foldable t => t Exp -> Exp -> Exp
        loop :: forall (t :: * -> *). Foldable t => t Exp -> Exp -> Exp
    loop t Exp
    as Exp
    e = (Exp -> Exp -> Exp) -> Exp -> t Exp -> Exp
    forall b a. (b -> a -> b) -> b -> t a -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Exp -> Exp -> Exp
    AppE Exp
    e t Exp
    as

    -- | Fuzzily speaking, converts a given IO type into a MonadIO m one.
    liftType :: Type -> Q Type
    liftType :: Type -> Q Type
    liftType = \case
      AppT Type
    _ Type
    t -> do
        m <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "m"
        return $
          ForallT
    #if MIN_VERSION_template_haskell(2,17,0)
            [PlainTV m SpecifiedSpec]
    #else
            [PlainTV m]

    #endif
            [AppT (ConT ''MonadIO) $ VarT m]
            (AppT (VarT m) t)
      Type
    t -> Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t