{-# LANGUAGE GADTs #-}

-- | Translate Copilot Core expressions and operators to C99.
module Copilot.Compile.C99.Translate where

import           Control.Monad.State
import qualified Data.List.NonEmpty  as NonEmpty

import Copilot.Core
import Copilot.Compile.C99.Error (impossible)
import Copilot.Compile.C99.Util

import qualified Language.C99.Simple as C

-- | Translates a Copilot Core expression into a C99 expression.
transexpr :: Expr a -> State FunEnv C.Expr
transexpr :: forall a. Expr a -> State FunEnv Expr
transexpr (Const Type a
ty a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Type a -> a -> Expr
constty Type a
ty a
x

transexpr (Local Type a1
ty1 Type a
_ Name
name Expr a1
e1 Expr a
e2) = do
  Expr
e1' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr a1
e1
  let cty1 :: Type
cty1 = forall a. Type a -> Type
transtype Type a1
ty1
      init :: Maybe Init
init = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Expr -> Init
C.InitExpr Expr
e1'
  forall m. Monoid m => m -> State m ()
statetell [Maybe StorageSpec -> Type -> Name -> Maybe Init -> Decln
C.VarDecln forall a. Maybe a
Nothing Type
cty1 Name
name Maybe Init
init]

  forall a. Expr a -> State FunEnv Expr
transexpr Expr a
e2

transexpr (Var Type a
_ Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Expr
C.Ident Name
n

transexpr (Drop Type a
_ DropIdx
amount Id
sid) = do
  let accessvar :: Name
accessvar = Id -> Name
streamaccessorname Id
sid
      index :: Expr
index     = Integer -> Expr
C.LitInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral DropIdx
amount)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Expr] -> Expr
funcall Name
accessvar [Expr
index]

transexpr (ExternVar Type a
_ Name
name Maybe [a]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Expr
C.Ident (Name -> Name
excpyname Name
name)

transexpr (Label Type a
_ Name
_ Expr a
e) = forall a. Expr a -> State FunEnv Expr
transexpr Expr a
e -- ignore label

transexpr (Op1 Op1 a1 a
op Expr a1
e) = do
  Expr
e' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr a1
e
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Op1 a b -> Expr -> Expr
transop1 Op1 a1 a
op Expr
e'

transexpr (Op2 Op2 a1 b a
op Expr a1
e1 Expr b
e2) = do
  Expr
e1' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr a1
e1
  Expr
e2' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr b
e2
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. Op2 a b c -> Expr -> Expr -> Expr
transop2 Op2 a1 b a
op Expr
e1' Expr
e2'

transexpr (Op3 Op3 a1 b c a
op Expr a1
e1 Expr b
e2 Expr c
e3) = do
  Expr
e1' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr a1
e1
  Expr
e2' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr b
e2
  Expr
e3' <- forall a. Expr a -> State FunEnv Expr
transexpr Expr c
e3
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c d. Op3 a b c d -> Expr -> Expr -> Expr -> Expr
transop3 Op3 a1 b c a
op Expr
e1' Expr
e2' Expr
e3'

-- | Translates a Copilot unary operator and its argument into a C99
-- expression.
transop1 :: Op1 a b -> C.Expr -> C.Expr
transop1 :: forall a b. Op1 a b -> Expr -> Expr
transop1 Op1 a b
op Expr
e =
  -- There are three types of ways in which a function in Copilot Core can be
  -- translated into C:
  --
  -- 1) Direct translation (perfect 1-to-1 mapping)
  -- 2) Type-directed translation (1-to-many mapping, choice based on type)
  -- 3) Desugaring/complex (expands to complex expression)
  case Op1 a b
op of
    Op1 a b
Not           -> Expr -> Expr
(C..!) Expr
e
    Abs      Type a
ty   -> forall a. Type a -> Expr -> Expr
transAbs Type a
ty Expr
e
    Sign     Type a
ty   -> forall a. Type a -> Expr -> Expr
transSign Type a
ty Expr
e
    Recip    Type a
ty   -> (forall a. Type a -> Integer -> Expr
constNumTy Type a
ty Integer
1) Expr -> Expr -> Expr
C../ Expr
e
    Acos     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"acos") [Expr
e]
    Asin     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"asin") [Expr
e]
    Atan     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"atan") [Expr
e]
    Cos      Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"cos") [Expr
e]
    Sin      Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"sin") [Expr
e]
    Tan      Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"tan") [Expr
e]
    Acosh    Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"acosh") [Expr
e]
    Asinh    Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"asinh") [Expr
e]
    Atanh    Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"atanh") [Expr
e]
    Cosh     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"cosh") [Expr
e]
    Sinh     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"sinh") [Expr
e]
    Tanh     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"tanh") [Expr
e]
    Exp      Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"exp") [Expr
e]
    Log      Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"log") [Expr
e]
    Sqrt     Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"sqrt") [Expr
e]
    Ceiling  Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"ceil") [Expr
e]
    Floor    Type a
ty   -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"floor") [Expr
e]
    BwNot    Type a
_    -> Expr -> Expr
(C..~) Expr
e
    Cast     Type a
_ Type b
ty -> TypeName -> Expr -> Expr
C.Cast (forall a. Type a -> TypeName
transtypename Type b
ty) Expr
e
    GetField (Struct a
_)  Type b
_ a -> Field s b
f -> Expr -> Name -> Expr
C.Dot Expr
e (forall a (s :: Symbol) t.
(Struct a, KnownSymbol s) =>
(a -> Field s t) -> Name
accessorname a -> Field s b
f)

-- | Translates a Copilot binary operator and its arguments into a C99
-- expression.
transop2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr
transop2 :: forall a b c. Op2 a b c -> Expr -> Expr -> Expr
transop2 Op2 a b c
op Expr
e1 Expr
e2 = case Op2 a b c
op of
  Op2 a b c
And          -> Expr
e1 Expr -> Expr -> Expr
C..&& Expr
e2
  Op2 a b c
Or           -> Expr
e1 Expr -> Expr -> Expr
C..|| Expr
e2
  Add      Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..+  Expr
e2
  Sub      Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..-  Expr
e2
  Mul      Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..*  Expr
e2
  Mod      Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..%  Expr
e2
  Div      Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C../  Expr
e2
  Fdiv     Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C../  Expr
e2
  Pow      Type a
ty  -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"pow") [Expr
e1, Expr
e2]
  Logb     Type a
ty  -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"log") [Expr
e2] Expr -> Expr -> Expr
C../
                  Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"log") [Expr
e1]
  Atan2    Type a
ty  -> Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"atan2") [Expr
e1, Expr
e2]
  Eq       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..== Expr
e2
  Ne       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..!= Expr
e2
  Le       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..<= Expr
e2
  Ge       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..>= Expr
e2
  Lt       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..<  Expr
e2
  Gt       Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..>  Expr
e2
  BwAnd    Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..&  Expr
e2
  BwOr     Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..|  Expr
e2
  BwXor    Type a
_   -> Expr
e1 Expr -> Expr -> Expr
C..^  Expr
e2
  BwShiftL Type a
_ Type b
_ -> Expr
e1 Expr -> Expr -> Expr
C..<< Expr
e2
  BwShiftR Type a
_ Type b
_ -> Expr
e1 Expr -> Expr -> Expr
C..>> Expr
e2
  Index    Type (Array n c)
_   -> Expr -> Expr -> Expr
C.Index Expr
e1 Expr
e2

-- | Translates a Copilot ternary operator and its arguments into a C99
-- expression.
transop3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr
transop3 :: forall a b c d. Op3 a b c d -> Expr -> Expr -> Expr -> Expr
transop3 Op3 a b c d
op Expr
e1 Expr
e2 Expr
e3 = case Op3 a b c d
op of
  Mux Type b
_ -> Expr -> Expr -> Expr -> Expr
C.Cond Expr
e1 Expr
e2 Expr
e3

-- | Translate @'Abs' e@ in Copilot Core into a C99 expression.
--
-- This function produces a portable implementation of abs in C99 that works
-- for the type given, provided that the output fits in a variable of the same
-- type (which may not be true, for example, for signed integers in the lower
-- end of their type range). If the absolute value is out of range, the
-- behavior is undefined.
--
-- PRE: The type given is a Num type (floating-point number, or a
-- signed/unsigned integer of fixed size).
transAbs :: Type a -> C.Expr -> C.Expr
transAbs :: forall a. Type a -> Expr -> Expr
transAbs Type a
ty Expr
e
    -- Abs for floats/doubles is called fabs in C99's math.h.
    | forall a. Type a -> Bool
typeIsFloating Type a
ty
    = Name -> [Expr] -> Expr
funcall (forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
"fabs") [Expr
e]

    -- C99 provides multiple implementations of abs, depending on the type of
    -- the arguments. For integers, it provides C99 abs, labs, and llabs, which
    -- take, respectively, an int, a long int, and a long long int.
    --
    -- However, the code produced by Copilot uses types with fixed width (e.g.,
    -- int16_t), and there is no guarantee that, for example, 32-bit int or
    -- 64-bit int will fit in a C int (only guaranteed to be 16 bits).
    -- Consequently, this function provides a portable version of abs for signed
    -- and unsigned ints implemented using shift and xor. For example, for a
    -- value x of type int32_t, the absolute value is:
    -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1))
    | Bool
otherwise
    = (Expr
e Expr -> Expr -> Expr
C..+ (Expr
e Expr -> Expr -> Expr
C..>> Expr
tyBitSizeMinus1)) Expr -> Expr -> Expr
C..^ (Expr
e Expr -> Expr -> Expr
C..>> Expr
tyBitSizeMinus1)
  where
    -- Size of an integer type in bits, minus one. It's easier to hard-code
    -- them than to try and generate the right expressions in C using sizeof.
    --
    -- PRE: the type 'ty' is a signed or unsigned integer type.
    tyBitSizeMinus1 :: C.Expr
    tyBitSizeMinus1 :: Expr
tyBitSizeMinus1 = case Type a
ty of
      Type a
Int8   -> Integer -> Expr
C.LitInt Integer
7
      Type a
Int16  -> Integer -> Expr
C.LitInt Integer
15
      Type a
Int32  -> Integer -> Expr
C.LitInt Integer
31
      Type a
Int64  -> Integer -> Expr
C.LitInt Integer
63
      Type a
Word8  -> Integer -> Expr
C.LitInt Integer
7
      Type a
Word16 -> Integer -> Expr
C.LitInt Integer
15
      Type a
Word32 -> Integer -> Expr
C.LitInt Integer
31
      Type a
Word64 -> Integer -> Expr
C.LitInt Integer
63
      Type a
_      -> forall a. Name -> Name -> a
impossible
                  Name
"transAbs"
                  Name
"copilot-c99"
                  Name
"Abs applied to unexpected types."

-- | Translate @'Sign' e@ in Copilot Core into a C99 expression.
--
-- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is:
--
-- 1. If @e@ is positive, return @1@.
--
-- 2. If @e@ is negative, return @-1@.
--
-- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the
--    type is an integral type. If the type is a floating-point type, it also
--    handles the cases where @e@ is @-0@ or @NaN@.
--
-- This implementation is modeled after how GHC implements 'signum'
-- <https://gitlab.haskell.org/ghc/ghc/-/blob/aed98ddaf72cc38fb570d8415cac5de9d8888818/libraries/base/GHC/Float.hs#L523-L525 here>.
transSign :: Type a -> C.Expr -> C.Expr
transSign :: forall a. Type a -> Expr -> Expr
transSign Type a
ty Expr
e = Expr -> Expr
positiveCase forall a b. (a -> b) -> a -> b
$ Expr -> Expr
negativeCase Expr
e
  where
    -- If @e@ is positive, return @1@, otherwise fall back to argument.
    --
    -- Produces the following code, where @<arg>@ is the argument to this
    -- function:
    -- @
    -- e > 0 ? 1 : <arg>
    -- @
    positiveCase :: C.Expr  -- ^ Value returned if @e@ is not positive.
                 -> C.Expr
    positiveCase :: Expr -> Expr
positiveCase =
      Expr -> Expr -> Expr -> Expr
C.Cond (BinaryOp -> Expr -> Expr -> Expr
C.BinaryOp BinaryOp
C.GT Expr
e (forall a. Type a -> Integer -> Expr
constNumTy Type a
ty Integer
0)) (forall a. Type a -> Integer -> Expr
constNumTy Type a
ty Integer
1)

    -- If @e@ is negative, return @1@, otherwise fall back to argument.
    --
    -- Produces the following code, where @<arg>@ is the argument to this
    -- function:
    -- @
    -- e < 0 ? -1 : <arg>
    -- @
    negativeCase :: C.Expr  -- ^ Value returned if @e@ is not negative.
                 -> C.Expr
    negativeCase :: Expr -> Expr
negativeCase =
      Expr -> Expr -> Expr -> Expr
C.Cond (BinaryOp -> Expr -> Expr -> Expr
C.BinaryOp BinaryOp
C.LT Expr
e (forall a. Type a -> Integer -> Expr
constNumTy Type a
ty Integer
0)) (forall a. Type a -> Integer -> Expr
constNumTy Type a
ty (-Integer
1))

-- | Transform a Copilot Core literal, based on its value and type, into a C99
-- literal.
constty :: Type a -> a -> C.Expr
constty :: forall a. Type a -> a -> Expr
constty Type a
ty = case Type a
ty of
  Type a
Bool      -> Bool -> Expr
C.LitBool
  Type a
Int8      -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Int16     -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Int32     -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Int64     -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Word8     -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Word16    -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Word32    -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Word64    -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Expr
C.LitInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Type a
Float     -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Expr
C.LitFloat
  Type a
Double    -> forall a. Type a -> Expr -> Expr
explicitty Type a
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Expr
C.LitDouble
  Struct a
_  -> \a
v ->
    TypeName -> NonEmpty InitItem -> Expr
C.InitVal (forall a. Type a -> TypeName
transtypename Type a
ty) (forall a. [Value a] -> NonEmpty InitItem
constStruct (forall a. Struct a => a -> [Value a]
toValues a
v))
  Array Type t
ty' -> \a
v ->
    TypeName -> NonEmpty InitItem -> Expr
C.InitVal (forall a. Type a -> TypeName
transtypename Type a
ty) (forall a. Type a -> [a] -> NonEmpty InitItem
constarray Type t
ty' (forall (n :: Nat) a. Array n a -> [a]
arrayelems a
v))

-- | Transform a Copilot Core literal, based on its value and type, into a C99
-- initializer.
constinit :: Type a -> a -> C.Init
constinit :: forall a. Type a -> a -> Init
constinit Type a
ty a
val = case Type a
ty of
  -- We include two special cases for Struct and Array to avoid using constty
  -- on them.
  --
  -- In the default case (i.e., InitExpr (constty ty val)), constant
  -- initializations are explicitly cast. However, doing so 1) may result in
  -- incorrect values for arrays, and 2) will be considered a non-constant
  -- expression in the case of arrays and structs, and thus not allowed as the
  -- initialization value for a global variable.
  --
  -- In particular, wrt. (1), for example, the nested array:
  --   [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32)
  --
  -- with explicit casts, will be initialized in C as:
  --   { (int32_t[2]){(int32_t)(0), (int32_t)(1)},
  --     (int32_t[2]){(int32_t)(2), (int32_t)(3)} }
  --
  -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the
  -- whole expression as an array of two int32_t's (as opposed to a nested
  -- array). This can either lead to compile-time errors (if you're lucky) or
  -- incorrect runtime semantics (if you're unlucky).
  Array Type t
ty' -> NonEmpty InitItem -> Init
C.InitList forall a b. (a -> b) -> a -> b
$ forall a. Type a -> [a] -> NonEmpty InitItem
constarray Type t
ty' forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) a. Array n a -> [a]
arrayelems a
val

  -- We use InitArray to initialize a struct because the syntax used for
  -- initializing arrays and structs is compatible. For instance, {1, 2} works
  -- both for initializing an int array of length 2 as well as a struct with
  -- two int fields, although the two expressions are conceptually different
  -- (structs can also be initialized as { .a = 1, .b = 2}.
  Struct a
_  -> NonEmpty InitItem -> Init
C.InitList forall a b. (a -> b) -> a -> b
$ forall a. [Value a] -> NonEmpty InitItem
constStruct (forall a. Struct a => a -> [Value a]
toValues a
val)
  Type a
_         -> Expr -> Init
C.InitExpr forall a b. (a -> b) -> a -> b
$ forall a. Type a -> a -> Expr
constty Type a
ty a
val

-- | Transform a Copilot Core struct field into a C99 initializer.
constfieldinit :: Value a -> C.InitItem
constfieldinit :: forall a. Value a -> InitItem
constfieldinit (Value Type t
ty (Field t
val)) = Maybe Name -> Init -> InitItem
C.InitItem forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Type a -> a -> Init
constinit Type t
ty t
val

-- | Transform a Copilot Struct, based on the struct fields, into a list of C99
-- initializer values.
constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem
constStruct :: forall a. [Value a] -> NonEmpty InitItem
constStruct [Value a]
val = forall a. [a] -> NonEmpty a
NonEmpty.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Value a -> InitItem
constfieldinit [Value a]
val

-- | Transform a Copilot Array, based on the element values and their type,
-- into a list of C99 initializer values.
constarray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem
constarray :: forall a. Type a -> [a] -> NonEmpty InitItem
constarray Type a
ty =
  forall a. [a] -> NonEmpty a
NonEmpty.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Maybe Name -> Init -> InitItem
C.InitItem forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> a -> Init
constinit Type a
ty)

-- | Explicitly cast a C99 value to a type.
explicitty :: Type a -> C.Expr -> C.Expr
explicitty :: forall a. Type a -> Expr -> Expr
explicitty Type a
ty = TypeName -> Expr -> Expr
C.Cast (forall a. Type a -> TypeName
transtypename Type a
ty)

-- | Translate a Copilot type to a C99 type.
transtype :: Type a -> C.Type
transtype :: forall a. Type a -> Type
transtype Type a
ty = case Type a
ty of
  Type a
Bool      -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"bool"
  Type a
Int8      -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"int8_t"
  Type a
Int16     -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"int16_t"
  Type a
Int32     -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"int32_t"
  Type a
Int64     -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"int64_t"
  Type a
Word8     -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"uint8_t"
  Type a
Word16    -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"uint16_t"
  Type a
Word32    -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"uint32_t"
  Type a
Word64    -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.TypedefName Name
"uint64_t"
  Type a
Float     -> TypeSpec -> Type
C.TypeSpec TypeSpec
C.Float
  Type a
Double    -> TypeSpec -> Type
C.TypeSpec TypeSpec
C.Double
  Array Type t
ty' -> Type -> Maybe Expr -> Type
C.Array (forall a. Type a -> Type
transtype Type t
ty') Maybe Expr
length
    where
      length :: Maybe Expr
length = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Expr
C.LitInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) t. KnownNat n => Type (Array n t) -> Id
tylength Type a
ty
  Struct a
s  -> TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Name -> TypeSpec
C.Struct (forall a. Struct a => a -> Name
typename a
s)

-- | Translate a Copilot type intro a C typename
transtypename :: Type a -> C.TypeName
transtypename :: forall a. Type a -> TypeName
transtypename Type a
ty = Type -> TypeName
C.TypeName forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type
transtype Type a
ty

-- Translate a literal number of type @ty@ into a C99 literal.
--
-- PRE: The type of PRE is numeric (integer or floating-point), that
-- is, not boolean, struct or array.
constNumTy :: Type a -> Integer -> C.Expr
constNumTy :: forall a. Type a -> Integer -> Expr
constNumTy Type a
ty =
  case Type a
ty of
    Type a
Float  -> Float -> Expr
C.LitFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
    Type a
Double -> Double -> Expr
C.LitDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
    Type a
_      -> Integer -> Expr
C.LitInt

-- | Provide a specialized function name in C99 for a function given the type
-- of its arguments, and its "family" name.
--
-- C99 provides multiple variants of the same conceptual function, based on the
-- types. Depending on the function, common variants exist for signed/unsigned
-- arguments, long or short types, float or double. The C99 standard uses the
-- same mechanism to name most such functions: the default variant works for
-- double, and there are additional variants for float and long double. For
-- example, the sin function operates on double, while sinf operates on float,
-- and sinl operates on long double.
--
-- This function only knows how to provide specialized names for functions in
-- math.h that provide a default version for a double argument and vary for
-- floats. It won't change the function name given if the variation is based on
-- the return type, if the function is defined elsewhere, or for other types.
specializeMathFunName :: Type a -> String -> String
specializeMathFunName :: forall a. Type a -> Name -> Name
specializeMathFunName Type a
ty Name
s
    -- The following function pattern matches based on the variants available
    -- for a specific function.
    --
    -- Do not assume that a function you need implemented follows the same
    -- standard as others: check whether it is present in the standard.
    | Name -> Bool
isMathFPArgs Name
s
    , Type a
Float <- Type a
ty
    = Name
s forall a. [a] -> [a] -> [a]
++ Name
"f"

    | Bool
otherwise
    = Name
s
  where
    -- True if the function family name is part of math.h and follows the
    -- standard rule of providing multiple variants for floating point numbers
    -- based on the type of their arguments.
    --
    -- Note: nan is not in this list because the names of its variants are
    -- determined by the return type.
    --
    -- For details, see:
    -- "B.11 Mathematics <math.h>" in the C99 standard
    isMathFPArgs :: String -> Bool
    isMathFPArgs :: Name -> Bool
isMathFPArgs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem
       [ Name
"acos",   Name
"asin",     Name
"atan",      Name
"atan2",      Name
"cos",    Name
"sin"
       , Name
"tan",    Name
"acosh",    Name
"asinh",     Name
"atanh",      Name
"cosh",   Name
"sinh"
       , Name
"tanh",   Name
"exp",      Name
"exp2",      Name
"expm1",      Name
"frexp",  Name
"ilogb"
       , Name
"ldexp",  Name
"log",      Name
"log10",     Name
"log1p",      Name
"log2",   Name
"logb"
       , Name
"modf",   Name
"scalbn",   Name
"scalbln",   Name
"cbrt",       Name
"fabs",   Name
"hypot"
       , Name
"pow",    Name
"sqrt",     Name
"erf",       Name
"erfc",       Name
"lgamma", Name
"tgamma"
       , Name
"ceil",   Name
"floor",    Name
"nearbyint", Name
"rint",       Name
"lrint",  Name
"llrint"
       , Name
"round",  Name
"lround",   Name
"llround",   Name
"trunc",      Name
"fmod",   Name
"remainder"
       , Name
"remquo", Name
"copysign", Name
"nextafter", Name
"nexttoward", Name
"fdim"
       , Name
"fmax",   Name
"fmin",     Name
"fma"
       ]

-- * Auxiliary functions

-- | True if the type given is a floating point number.
typeIsFloating :: Type a -> Bool
typeIsFloating :: forall a. Type a -> Bool
typeIsFloating Type a
Float  = Bool
True
typeIsFloating Type a
Double = Bool
True
typeIsFloating Type a
_      = Bool
False