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

-- |
-- Module      : Language.C.Inline.Hint
-- Copyright   : [2013..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 the definition of marshalling hints.

module Language.C.Inline.Hint (
  -- * Annotations
  Annotated(..), (<:), void, annotatedShowQ,
  
  -- * Hints
  Hint(..), 
  
  -- * Querying of annotated entities
  haskellTypeOf, foreignTypeOf, newForeignPtrOf, stripAnnotation
) where

  -- common libraries
import Control.Applicative
import Language.Haskell.TH        as TH
import Language.Haskell.TH.Syntax as TH

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

  -- friends
import Language.C.Inline.Error


-- |Annotating entities with hints.
--
-- The alternatives are to provide an explicit marshalling hint with '(:>)', or to leave the marshalling
-- implicitly defined by the name's type.
--
data Annotated e where
  (:>)  :: Hint hint => e    -> hint -> Annotated e         -- explicit marshalling hint
  Typed ::              Name         -> Annotated Name      -- marshalling implicitly defined by name's type

-- |We provide additional syntax where the hint is to the left of the annotated entity.
--
(<:) :: Hint hint => hint -> e -> Annotated e
(<:) = flip (:>)

-- |Annotation for irrelevant results
--
void :: e -> Annotated e
void = (''() <:)

-- |Pretty print an annotated entity.
--
annotatedShowQ :: Show e => Annotated e -> Q String
annotatedShowQ (e :> hint)  = ((show e ++ " :> ") ++) <$> showQ hint
annotatedShowQ (Typed name) = return $ "Typed " ++ show name

-- |Hints imply marshalling strategies, which include source and destination types for marshalling.
--
class Hint hint where
  haskellType       :: hint -> Q TH.Type
  foreignType       :: hint -> Q (Maybe QC.Type)  -- ^In case of 'Nothing', the foreign type is determined by the Haskell type.
  showQ             :: hint -> Q String
  newForeignPtrName :: hint -> Q (Maybe TH.Name)
  
instance Hint Name where   -- must be a type name
  haskellType       = conT
  foreignType       = const (return Nothing)
  showQ             = return . show
  newForeignPtrName = const (return Nothing)
      
instance Hint (Q TH.Type) where
  haskellType       = id
  foreignType       = const (return Nothing)
  showQ             = (show <$>)
  newForeignPtrName = const (return Nothing)

-- |Determine the Haskell type implied for the given annotated entity.
--
haskellTypeOf :: Annotated e -> Q TH.Type
haskellTypeOf (_ :> hint)  = haskellType hint
haskellTypeOf (Typed name)
  = do
    { info <- reify name
    ; case info of
        ClassOpI _ ty _ _ -> return ty
        VarI     _ ty _ _ -> return ty
        nonVarInfo    -> 
          do
          { reportErrorAndFail QC.ObjC $ 
              "expected '" ++ show name ++ "' to be a typed variable name, but it is " ++ 
              show (TH.ppr nonVarInfo)
          }
    }

-- |Determine the foreign type *directly* implied for the given annotated entity if any.
--
foreignTypeOf :: Annotated e -> Q (Maybe QC.Type)
foreignTypeOf (_ :> hint)  = foreignType hint
foreignTypeOf (Typed name) = return Nothing

-- |Determine the name of the function to create a new foreign pointer for this type if any.
--
newForeignPtrOf :: Annotated e -> Q (Maybe TH.Name)
newForeignPtrOf (_ :> hint)  = newForeignPtrName hint
newForeignPtrOf (Typed name) = return Nothing

-- |Remove the annotation.
--
stripAnnotation :: Annotated e -> e
stripAnnotation (e :> hint)  = e
stripAnnotation (Typed name) = name