Quote.hs

{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeInType             #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE ViewPatterns           #-}
{-# OPTIONS -Wno-partial-type-signatures #-}
module Clr.Inline.Types.Quote
  ( Quotable
  , lookupDelegateMarshalType
  , lookupQuotableClrType
  , MarshalType
  , lookupQuotableMarshalType
  , lookupQuotableUnmarshalType
  ) where

import           Clr.Host.BStr
import           Clr.Marshal
import           Clr.Inline.Types
import           Data.Int
import           Data.Maybe
import           Data.Monoid
import           Data.Text            (Text)
import           Data.Word
import           GHC.TypeLits
import           Language.Haskell.TH
import           Text.Printf

-- | Extensible mapping between quotable CLR types and Haskell types
class Unmarshal marshal unmarshal =>
         Quotable (quoted::Symbol) (clr::Symbol)    marshal     unmarshal
instance Quotable "bool"           "System.Boolean" Bool        Bool
instance Quotable "double"         "System.Double"  Double      Double
instance Quotable "int"            "System.Int32"   Int         Int
instance Quotable "int16"          "System.Int16"   Int16       Int16
instance Quotable "int32"          "System.Int32"   Int32       Int32
instance Quotable "int64"          "System.Int64"   Int64       Int64
instance Quotable "long"           "System.Int64"   Int64       Int64
instance Quotable "uint16"         "System.UInt16"  Word16      Word16
instance Quotable "word16"         "System.UInt16"  Word16      Word16
instance Quotable "uint32"         "System.UInt32"  Word32      Word32
instance Quotable "word32"         "System.UInt32"  Word32      Word32
instance Quotable "uint64"         "System.UInt64"  Word64      Word64
instance Quotable "word64"         "System.UInt64"  Word64      Word64
instance Quotable "string"         "System.String"  BStr        String
instance Quotable "text"           "System.String"  TextBStr    Text
instance Quotable "void"           "System.Void"    ()          ()
instance Quotable "unit" "Microsoft.FSharp.Core.Unit" ()        ()
-- | All reference types are handled by this instance.
instance Quotable a                a                (ClrPtr a)  (Clr a)

lookupQuotable :: Show a => ([InstanceDec] -> a) -> String -> Q a
lookupQuotable extract quote = do
  let ty = LitT (StrTyLit quote)
  a <- newName "clr"
  b <- newName "rep"
  c <- newName "haskell"
  instances <- reifyInstances ''Quotable [ ty, VarT a, VarT b, VarT c ]
  return $ extract instances

handleOverlappingInstances :: String -> String -> [Dec] -> a
handleOverlappingInstances msg s instances = error $ printf "Overlapping %s instances for Quotable %s: %s" msg s (show names) -- (show instances)
  where
    names = [ quote | InstanceD _ _ (_ `AppT` quote `AppT` _ `AppT` _ `AppT` _) _ <- instances ]

extractMostSpecificInstance :: String -> String -> _ -> _ -> [Dec] -> _
extractMostSpecificInstance s msg f1 f2 instances =
  fromMaybe (handleOverlappingInstances msg s instances) . getFirst $
  foldMap (apply f1) instances <> foldMap (apply f2) instances
  where
    apply f (InstanceD _ _ (_ `AppT` quote `AppT` clr `AppT` marshal `AppT` unmarshal) _) = First $ f quote clr marshal unmarshal
    apply _ _ = error "unreachable"

lookupQuotableClrType :: String -> Q ClrTypeSymbol
lookupQuotableClrType s = lookupQuotable extract s
    where
      extract = extractMostSpecificInstance s "Clr" specific general
      specific _ (LitT (StrTyLit s)) _ _ = Just $ ClrTypeSymbol s
      specific _ _ _ _ = Nothing
      general quote@VarT{} clr@VarT{} _ _ | quote == clr = Just $ ClrTypeSymbol s
      general _ _ _ _ = Nothing

type MarshalType = Type

lookupQuotableMarshalType :: String -> Q MarshalType
lookupQuotableMarshalType s = lookupQuotable extract s
  where
    extract = extractMostSpecificInstance s "Marshal" specific general
    specific LitT{} LitT{} marshalTy _ = Just marshalTy
    specific _ _ _ _ = Nothing
    general quote@VarT{} clr@VarT{} (con `AppT` v)  _ | quote == clr && quote == v= Just $ AppT con (LitT (StrTyLit s))
    general _ _ _ _ = Nothing

lookupDelegateMarshalType :: [String] -> TypeQ -> Q MarshalType
lookupDelegateMarshalType args resTy =
      foldr (\t u -> arrowT `appT` lookupQuotableMarshalType t `appT` u) [t| IO $(resTy) |] args

lookupQuotableUnmarshalType :: String -> Q Type
lookupQuotableUnmarshalType s = lookupQuotable extract s
  where
    extract = extractMostSpecificInstance s "Unmarshal" specific general
    specific LitT{} LitT{} _ unmarshalTy = Just unmarshalTy
    specific _ _ _ _ = Nothing
    general quote@VarT{} clr@VarT{} _ (con `AppT` v) | quote == clr && quote == v = Just $ AppT con (LitT (StrTyLit s))
    general _ _ _ _ = Nothing