{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances, ViewPatterns, CPP #-}

-- |
-- Module      : Language.C.Inline.TH
-- Copyright   : 2014 Manuel M T Chakravarty
-- License     : BSD3
--
-- Maintainer  : Manuel M T Chakravarty <chak@justtesting.org>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- This module provides Template Haskell convenience functions.

module Language.C.Inline.TH (
  -- * Decompose type expressions
  headTyConName, headTyConNameOrError,

  -- * Decompose idiomatic declarations
  foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper
) where

  -- standard libraries
import Control.Applicative
import Foreign.Ptr
import Foreign.ForeignPtr
import Language.Haskell.TH        as TH

  -- quasi-quotation libraries
import Language.C.Quote           as QC

  -- friends
import Language.C.Inline.Error


-- |Project the name of the head of a type term if it is a type constructor.
--
headTyConName :: TH.Type -> Maybe TH.Name
headTyConName ty
  = case splitAppTy ty of
      (ConT name, _) -> Just name
      _              -> Nothing

-- |Like 'headTyConName', but fail if the head is not a type constructor.
--
headTyConNameOrError :: QC.Extensions -> TH.Type -> Q TH.Name
headTyConNameOrError lang ty
  = case headTyConName ty of
      Just name -> return name
      Nothing   -> reportErrorAndFail lang $ "expected the head of '" ++ show ty ++ "' to be a type constructor"

-- |Decompose an n-ary type application into its head and arguments.
--
splitAppTy :: TH.Type -> (TH.Type, [TH.Type])
splitAppTy = split []
  where
    split args (ty `AppT` arg) = split (arg:args) ty
    split args (SigT ty _)     = split args       ty
    split args ty              = (ty, args)

-- |Obtain the data constructor of the newtype in an idiomatic 'ForeignPtr' wrapper of the form
--
-- > newtype Wrapper <tvs> = Wrapper (ForeignPtr (Wrapper <tvs>))
--
foreignWrapperDatacon :: TH.Type -> Q TH.Exp
foreignWrapperDatacon ty
  = do
    { (datacon, _) <- decomposeForeignPtrWrapper ty
    ; return $ ConE datacon
    }

-- |Unwraps a newtype wrapper around a foreign pointer and turns the 'ForeignPtr' into a 'Ptr'.
--
ptrOfForeignPtrWrapper :: TH.Type -> Q TH.Type
ptrOfForeignPtrWrapper ty = [t| Ptr $(snd <$> decomposeForeignPtrWrapper ty) |]

-- |Generate code that unwraps the foreign pointer inside the given foreign pointer wrapper type.
--
unwrapForeignPtrWrapper :: TH.Type -> Q TH.Exp
unwrapForeignPtrWrapper ty
  = do
    { (datacon, _) <- decomposeForeignPtrWrapper ty
    ; v <- newName "v"
    ; [| \e -> $(caseE [| e |] [match (conP datacon [varP v]) (normalB $ varE v) []]) |]
    }

-- |Given a type whose head is a newtype wrapper around a foreign pointer of the form
--
-- > newtype Wrapper <tvs> = Wrapper (ForeignPtr (Wrapper <tvs>))
--
-- return the name of the wrapper data constructor and type argument of the 'ForeignPtr', where all '<tvs>' have been
-- substituted by the arguments in the type application constituting the input type (might be nullary).
--
decomposeForeignPtrWrapper :: TH.Type -> Q (TH.Name, TH.Type)
decomposeForeignPtrWrapper ty
  = do
    { let (tycon, args) = splitAppTy ty
    ; name <- case tycon of
                ConT name -> return name
                _         ->
                  do
                  { reportErrorAndFail QC.ObjC $
                      "expected '" ++ show tycon ++ "' be a type constructor of a 'ForeignPtr' wrapper"
                  }

    ; reifyUntilFixedPoint args name
    }
  where
    reifyUntilFixedPoint args name
      = do 
        { info <- reify name
        ; case info of
            TyConI (NewtypeD [] _name tvs (NormalC dataconName [(_strict, ConT fptr `AppT` ptrArg)]) _deriv)
              | fptr == ''ForeignPtr
              -> return (dataconName, substitute (zip args tvs) ptrArg)
            TyConI (TySynD _name tvs (headTyConName -> Just name'))
              -> do
                 { (dcname, type0) <- reifyUntilFixedPoint (drop (length tvs) args) name'
                 ; return (dcname, substitute (zip args tvs) type0)
                 }
            nonForeign -> 
              do
              { reportErrorAndFail QC.ObjC $
                  "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++
                  show (TH.ppr nonForeign)
              }        }
    substitute :: [(TH.Type, TH.TyVarBndr)] -> TH.Type -> TH.Type
    substitute subst (ForallT boundTvs cxt' body)
      = ForallT boundTvs (substituteCxt subst' cxt') (substitute subst' body)
      where
        subst' = filter (`notShadowedBy` map theTV boundTvs) subst
        --
        (_, tv) `notShadowedBy` boundTvs' = theTV tv `notElem` boundTvs'
        --
        theTV (PlainTV tv)    = tv
        theTV (KindedTV tv _) = tv
    substitute subst (t1 `AppT` t2)
      = (substitute subst t1) `AppT` (substitute subst t2)
    substitute subst (SigT ty' ki)
      = SigT (substitute subst ty') ki
    substitute subst (VarT tv)
      = substituteName subst tv
    substitute _subst ty'
      = ty'

    substituteCxt subst cxt' = map (substitutePred subst) cxt'

#if __GLASGOW_HASKELL__ < 709
    substitutePred subst (ClassP name tys) = ClassP name (map (substitute subst) tys)
    substitutePred subst (EqualP ty1 ty2)  = EqualP (substitute subst ty1) (substitute subst ty2)
#else
    -- Constraints are just types now.
    substitutePred = substitute
#endif

    substituteName []               tv     = VarT tv
    substituteName ((arg, tv):_args) thisTv
      | tv `matches` thisTv = arg
      | otherwise           = VarT thisTv

    PlainTV  name     `matches` thisTv = name == thisTv
    KindedTV name _ki `matches` thisTv = name == thisTv
