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

-- |
-- Module      : Language.C.Inline.TH
-- Copyright   : [2014..2016] 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
import Language.Haskell.TH.Quote  as TH
import Language.Haskell.TH.Syntax as TH

  -- quasi-quotation libraries
import Language.C.Parser          as QC
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"
                  }

    ; 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)
        nonForeign -> 
          do
          { reportErrorAndFail QC.ObjC $ 
              "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ 
              show (TH.ppr nonForeign)
          }
    }
  where
    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 (substitute subst) cxt
    
    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