{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Embedded.Backend.C.Expression where



import Data.Int
import Data.Word
import Data.Proxy
import Data.Typeable
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif

import Language.C.Monad
import Language.C.Quote.C
import Language.C.Syntax (Exp,Type)
import qualified Language.C.Syntax as C

import Control.Monad.Operational.Higher

import Language.Embedded.Expression



-- | General interface for compiling expressions
class FreeExp exp => CompExp exp
  -- The super class is motivated by the fact that compilation of functions
  -- `exp a -> exp b` can be done by constructing an argument using `varExp`.
  where
    -- | Compilation of expressions
    compExp :: MonadC m => exp a -> m Exp

-- | Types supported by C
class (Show a, Eq a, Typeable a) => CType a
  where
    cType :: MonadC m => proxy a -> m Type

    cLit         :: MonadC m => a -> m Exp
    default cLit :: (ToExp a, MonadC m) => a -> m Exp
    cLit = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> (a -> Exp) -> a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> SrcLoc -> Exp) -> SrcLoc -> a -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
toExp SrcLoc
forall a. Monoid a => a
mempty

instance CType Bool
  where
    cType :: proxy Bool -> m Type
cType proxy Bool
_ = do
        String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdbool.h"
        Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename bool |]
    cLit :: Bool -> m Exp
cLit Bool
b = do
        String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdbool.h"
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ if Bool
b then [cexp| true |] else [cexp| false |]

instance CType Int8   where cType :: proxy Int8 -> m Type
cType proxy Int8
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int8_t   |]
instance CType Int16  where cType :: proxy Int16 -> m Type
cType proxy Int16
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int16_t  |]
instance CType Int32  where cType :: proxy Int32 -> m Type
cType proxy Int32
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int32_t  |]
instance CType Int64  where cType :: proxy Int64 -> m Type
cType proxy Int64
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int64_t  |]
instance CType Word8  where cType :: proxy Word8 -> m Type
cType proxy Word8
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint8_t  |]
instance CType Word16 where cType :: proxy Word16 -> m Type
cType proxy Word16
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint16_t |]
instance CType Word32 where cType :: proxy Word32 -> m Type
cType proxy Word32
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint32_t |]
instance CType Word64 where cType :: proxy Word64 -> m Type
cType proxy Word64
_ = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addSystemInclude String
"stdint.h"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint64_t |]

instance CType Float  where cType :: proxy Float -> m Type
cType proxy Float
_ = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| float |]
instance CType Double where cType :: proxy Double -> m Type
cType proxy Double
_ = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| double |]

-- | Remove one layer of a nested proxy
proxyArg :: proxy1 (proxy2 a) -> Proxy a
proxyArg :: proxy1 (proxy2 a) -> Proxy a
proxyArg proxy1 (proxy2 a)
_ = Proxy a
forall k (t :: k). Proxy t
Proxy

-- | Classes that support reification to C types
class CompTypeClass ct
  where
    compType :: (ct a, MonadC m) => proxy1 ct -> proxy2 a -> m Type
    compLit  :: (ct a, MonadC m) => proxy ct -> a -> m Exp

instance CompTypeClass CType
  where
    compType :: proxy1 CType -> proxy2 a -> m Type
compType proxy1 CType
_ = proxy2 a -> m Type
forall a (m :: * -> *) (proxy :: * -> *).
(CType a, MonadC m) =>
proxy a -> m Type
cType
    compLit :: proxy CType -> a -> m Exp
compLit proxy CType
_  = a -> m Exp
forall a (m :: * -> *). (CType a, MonadC m) => a -> m Exp
cLit

-- | Get the type predicate from an instruction type
proxyPred :: cmd (Param3 p e pred) a -> Proxy pred
proxyPred :: cmd (Param3 p e pred) a -> Proxy pred
proxyPred cmd (Param3 p e pred) a
_ = Proxy pred
forall k (t :: k). Proxy t
Proxy

-- | Create and declare a fresh variable
freshVar :: forall m ct proxy a . (MonadC m, CompTypeClass ct, ct a) =>
    proxy ct -> m (Val a)
freshVar :: proxy ct -> m (Val a)
freshVar proxy ct
ct = do
    String
v <- String -> m String
forall (m :: * -> *). MonadC m => String -> m String
gensym String
"v"
    String -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar String
v
    Type
t <- proxy ct -> Proxy a -> m Type
forall (ct :: * -> Constraint) a (m :: * -> *)
       (proxy1 :: (* -> Constraint) -> *) (proxy2 :: * -> *).
(CompTypeClass ct, ct a, MonadC m) =>
proxy1 ct -> proxy2 a -> m Type
compType proxy ct
ct (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    case Type
t of
      C.Type DeclSpec
_ C.Ptr{} SrcLoc
_ -> InitGroup -> m ()
forall (m :: * -> *). MonadC m => InitGroup -> m ()
addLocal [cdecl| $ty:t $id:v = NULL; |]
      Type
_                  -> InitGroup -> m ()
forall (m :: * -> *). MonadC m => InitGroup -> m ()
addLocal [cdecl| $ty:t $id:v; |]
    Val a -> m (Val a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Val a
forall a. String -> Val a
ValComp String
v)