    {-|

    Module      : SDL.Raw.Helper
    Copyright   : (c) 2015 Siniša Biđin
    License     : MIT
    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.

    -}

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

    module SDL.Raw.Helper (liftF) where

    import Control.Monad           (replicateM)
    import Control.Monad.IO.Class  (MonadIO, liftIO)
    import Language.Haskell.TH
    import Language.Haskell.TH.Datatype.TyVarBndr (plainTVSpecified)

    -- | 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 {t}. Num t => t -> Type -> t
    count Int
    0
      where
        count :: t -> Type -> t
    count !t
    n = \case
          (AppT (AppT Type
    ArrowT Type
    _) Type
    t) -> t -> Type -> t
    count (t
    nt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1) Type
    t
          (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t) -> t -> Type -> t
    count t
    n Type
    t
          (SigT Type
    t Type
    _)      -> t -> Type -> t
    count t
    n Type
    t
          Type
    _               -> t
    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 :: 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
            [plainTVSpecified m]
            [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