content: {-# 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
  