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

-- |
--
-- Module  : SDL.Raw.Helper
-- License : BSD3
--
-- 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 fname cname ftype = do
  let f' = mkName $ fname ++ "'" -- Direct binding.
  let f = mkName fname -- Lifted.
  t' <- 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
    [] -> ((: []) . SigD f) `fmap` liftType t'
    _ -> 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 = count 0
  where
    count :: Num p => p -> Type -> p
    count !n = \case
      (AppT (AppT ArrowT _) t) -> count (n + 1) t
      (ForallT _ _ t) -> count n t
      (SigT t _) -> count n t
      _ -> n

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

-- | Fuzzily speaking, converts a given IO type into a MonadIO m one.
liftType :: Type -> Q Type
liftType = \case
  AppT _ t -> do
    m <- newName "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)
  t -> return t