{-# LANGUAGE DataKinds,
             FlexibleContexts,
             GADTs,
             RankNTypes,
             KindSignatures #-}

----------------------------------------------------------------
--                                                    2016.07.11
-- |
-- Module      :  Language.Hakaru.CodeGen.Types
-- Copyright   :  Copyright (c) 2016 the Hakaru team
-- License     :  BSD3
-- Maintainer  :  zsulliva@indiana.edu
-- Stability   :  experimental
-- Portability :  GHC-only
--
-- Provides tools for building C Types from Hakaru types
--
----------------------------------------------------------------

module Language.Hakaru.CodeGen.Types
  ( buildDeclaration
  , buildDeclaration'
  , buildPtrDeclaration

  -- tools for building C types
  , typeDeclaration
  , typePtrDeclaration
  , typeName

  -- arrays
  , arrayDeclaration
  , arrayStruct
  , arraySize
  , arrayData
  , arrayPtrSize
  , arrayPtrData

  -- mdata
  , mdataDeclaration
  , mdataPtrDeclaration
  , mdataStruct
  , mdataStruct'
  , mdataWeight
  , mdataSample
  , mdataPtrWeight
  , mdataPtrSample

  -- datum
  , datumDeclaration
  , datumStruct
  , datumSum
  , datumProd
  , datumFst
  , datumSnd
  , datumIndex

  -- functions and closures
  , functionDef
  , closureStructure

  , buildType
  , castTo
  , castToPtrOf
  , callStruct
  , buildStruct
  , buildUnion
  , binaryOp
  ) where

import Control.Monad.State

import Language.Hakaru.Syntax.ABT
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Syntax.IClasses
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Types.HClasses
import Language.Hakaru.Types.Sing
import Language.Hakaru.CodeGen.AST
import Language.Hakaru.CodeGen.Libs

buildDeclaration :: CTypeSpec -> Ident -> CDecl
buildDeclaration :: CTypeSpec -> Ident -> CDecl
buildDeclaration CTypeSpec
ctyp Ident
ident =
  [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [ CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
ctyp ]
        [( Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident)
         , Maybe CInit
forall a. Maybe a
Nothing)]

buildDeclaration' :: [CTypeSpec] -> Ident -> CDecl
buildDeclaration' :: [CTypeSpec] -> Ident -> CDecl
buildDeclaration' [CTypeSpec]
specs Ident
ident =
  [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl ((CTypeSpec -> CDeclSpec) -> [CTypeSpec] -> [CDeclSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> CDeclSpec
CTypeSpec [CTypeSpec]
specs)
        [( Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident)
         , Maybe CInit
forall a. Maybe a
Nothing)]

buildPtrDeclaration :: CTypeSpec -> Ident -> CDecl
buildPtrDeclaration :: CTypeSpec -> Ident -> CDecl
buildPtrDeclaration CTypeSpec
ctyp Ident
ident =
  [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [ CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
ctyp ]
        [( Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr (CPtrDeclr -> Maybe CPtrDeclr
forall a. a -> Maybe a
Just (CPtrDeclr -> Maybe CPtrDeclr) -> CPtrDeclr -> Maybe CPtrDeclr
forall a b. (a -> b) -> a -> b
$ [CTypeQual] -> CPtrDeclr
CPtrDeclr []) (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident)
         , Maybe CInit
forall a. Maybe a
Nothing)]

typeDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typeDeclaration :: Sing a -> Ident -> CDecl
typeDeclaration Sing a
typ Ident
ident =
  [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl ((CTypeSpec -> CDeclSpec) -> [CTypeSpec] -> [CDeclSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> CDeclSpec
CTypeSpec ([CTypeSpec] -> [CDeclSpec]) -> [CTypeSpec] -> [CDeclSpec]
forall a b. (a -> b) -> a -> b
$ Sing a -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing a
typ)
        [( Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident)
         , Maybe CInit
forall a. Maybe a
Nothing)]

typePtrDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typePtrDeclaration :: Sing a -> Ident -> CDecl
typePtrDeclaration Sing a
typ Ident
ident =
  [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl ((CTypeSpec -> CDeclSpec) -> [CTypeSpec] -> [CDeclSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> CDeclSpec
CTypeSpec ([CTypeSpec] -> [CDeclSpec]) -> [CTypeSpec] -> [CDeclSpec]
forall a b. (a -> b) -> a -> b
$ Sing a -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing a
typ)
        [( Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr (CPtrDeclr -> Maybe CPtrDeclr
forall a. a -> Maybe a
Just (CPtrDeclr -> Maybe CPtrDeclr) -> CPtrDeclr -> Maybe CPtrDeclr
forall a b. (a -> b) -> a -> b
$ [CTypeQual] -> CPtrDeclr
CPtrDeclr [])
                  (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident)
         , Maybe CInit
forall a. Maybe a
Nothing)]


----------------
-- Type Names --
----------------
{-
Type names are used when constructing C structures. In most cases there is a
unique C structure name for a Hakaru type. This is not the case for functions
which are compiled into closures, which are unique to a certain context and
Hakaru type.
-}

typeName :: Sing (a :: Hakaru) -> String
typeName :: Sing a -> String
typeName Sing a
SInt         = String
"int"
typeName Sing a
SNat         = String
"nat"
typeName Sing a
SReal        = String
"real"
typeName Sing a
SProb        = String
"prob"
typeName (SArray t)   = String
"array_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall (a :: Hakaru). Sing a -> String
typeName Sing a
t
typeName (SMeasure t) = String
"mdata_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall (a :: Hakaru). Sing a -> String
typeName Sing a
t
typeName f :: Sing a
f@(SFun _ _)  = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"typeName{SFun} doen't make sense: unknown context for {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall a. Show a => a -> String
show Sing a
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
typeName (SData _ t)  = String
"dat_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing (Code t) -> String
forall (a :: [[HakaruFun]]). Sing a -> String
datumSumName Sing (Code t)
t
  where datumSumName :: Sing (a :: [[HakaruFun]]) -> String
        datumSumName :: Sing a -> String
datumSumName Sing a
SVoid = String
"V"
        datumSumName (SPlus p s) = Sing xs -> String
forall (a :: [HakaruFun]). Sing a -> String
datumProdName Sing xs
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing xss -> String
forall (a :: [[HakaruFun]]). Sing a -> String
datumSumName Sing xss
s

        datumProdName :: Sing (a :: [HakaruFun]) -> String
        datumProdName :: Sing a -> String
datumProdName Sing a
SDone     = String
"D"
        datumProdName (SEt x p) = Sing x -> String
forall (a :: HakaruFun). Sing a -> String
datumPrimName Sing x
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing xs -> String
forall (a :: [HakaruFun]). Sing a -> String
datumProdName Sing xs
p

        datumPrimName :: Sing (a :: HakaruFun) -> String
        datumPrimName :: Sing a -> String
datumPrimName Sing a
SIdent = String
"I"
        datumPrimName (SKonst s) = String
"K" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall (a :: Hakaru). Sing a -> String
typeName Sing a
s




--------------------------------------------------------------------------------
--                                   Arrays                                   --
--------------------------------------------------------------------------------
{-
  We represent arrays as structs with an 'unsigned int' for the size and a
  pointer to a block of array elements.

  Because arrays may point to undeclared types (such as arrays of datum), we
  need to return a list of external declarations with our array type
-}

arrayStruct :: Sing (a :: Hakaru) -> CExtDecl
arrayStruct :: Sing a -> CExtDecl
arrayStruct Sing a
t = CDecl -> CExtDecl
CDeclExt ([CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec (CTypeSpec -> CDeclSpec) -> CTypeSpec -> CDeclSpec
forall a b. (a -> b) -> a -> b
$ Sing a -> CTypeSpec
forall (a :: Hakaru). Sing a -> CTypeSpec
arrayStruct' Sing a
t] [])

arrayStruct' :: Sing (a :: Hakaru) -> CTypeSpec
arrayStruct' :: Sing a -> CTypeSpec
arrayStruct' Sing a
t = CTypeSpec
aStruct
  where aSize :: CDecl
aSize   = [CTypeSpec] -> Ident -> CDecl
buildDeclaration' [CTypeSpec
CUnsigned,CTypeSpec
CInt] (String -> Ident
Ident String
"size")
        aData :: CDecl
aData   = Sing a -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typePtrDeclaration Sing a
t (String -> Ident
Ident String
"data")
        aStruct :: CTypeSpec
aStruct = Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct (Ident -> Maybe Ident
forall a. a -> Maybe a
Just (Ident -> Maybe Ident)
-> (Sing a -> Ident) -> Sing a -> Maybe Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident (String -> Ident) -> (Sing a -> String) -> Sing a -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HArray a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HArray a) -> String)
-> (Sing a -> Sing ('HArray a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray (Sing a -> Maybe Ident) -> Sing a -> Maybe Ident
forall a b. (a -> b) -> a -> b
$ Sing a
t) [CDecl
aSize,CDecl
aData]


arrayDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
arrayDeclaration :: Sing a -> Ident -> CDecl
arrayDeclaration = CTypeSpec -> Ident -> CDecl
buildDeclaration (CTypeSpec -> Ident -> CDecl)
-> (Sing a -> CTypeSpec) -> Sing a -> Ident -> CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HArray a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HArray a) -> String)
-> (Sing a -> Sing ('HArray a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray


arraySize :: CExpr -> CExpr
arraySize :: CExpr -> CExpr
arraySize CExpr
e = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
e (String -> Ident
Ident String
"size") Bool
True

arrayData :: CExpr -> CExpr
arrayData :: CExpr -> CExpr
arrayData CExpr
e = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
e (String -> Ident
Ident String
"data") Bool
True

arrayPtrSize :: CExpr -> CExpr
arrayPtrSize :: CExpr -> CExpr
arrayPtrSize CExpr
e = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
e (String -> Ident
Ident String
"size") Bool
False

arrayPtrData :: CExpr -> CExpr
arrayPtrData :: CExpr -> CExpr
arrayPtrData CExpr
e = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
e (String -> Ident
Ident String
"data") Bool
False



--------------------------------------------------------------------------------
--                                  Measure Data                              --
--------------------------------------------------------------------------------
{-
  Measure datum are structures that will be used for sampling. We represent it
  as a structure with a 'double' in log-domain corresponding to the weight of
  the sample and an item of the sample type.
-}

mdataStruct :: Sing (a :: Hakaru) -> CExtDecl
mdataStruct :: Sing a -> CExtDecl
mdataStruct Sing a
t = CDecl -> CExtDecl
CDeclExt ([CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec (CTypeSpec -> CDeclSpec) -> CTypeSpec -> CDeclSpec
forall a b. (a -> b) -> a -> b
$ Sing a -> CTypeSpec
forall (a :: Hakaru). Sing a -> CTypeSpec
mdataStruct' Sing a
t] [])

mdataStruct' :: Sing (a :: Hakaru) -> CTypeSpec
mdataStruct' :: Sing a -> CTypeSpec
mdataStruct' Sing a
t = CTypeSpec
mdStruct
  where weight :: CDecl
weight = CTypeSpec -> Ident -> CDecl
buildDeclaration CTypeSpec
CDouble (String -> Ident
Ident String
"weight")
        sample :: CDecl
sample = Sing a -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing a
t (String -> Ident
Ident String
"sample")
        mdStruct :: CTypeSpec
mdStruct = Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct (Ident -> Maybe Ident
forall a. a -> Maybe a
Just (Ident -> Maybe Ident)
-> (Sing a -> Ident) -> Sing a -> Maybe Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident (String -> Ident) -> (Sing a -> String) -> Sing a -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HMeasure a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HMeasure a) -> String)
-> (Sing a -> Sing ('HMeasure a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing a -> Maybe Ident) -> Sing a -> Maybe Ident
forall a b. (a -> b) -> a -> b
$ Sing a
t) [CDecl
weight,CDecl
sample]

mdataDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
mdataDeclaration :: Sing a -> Ident -> CDecl
mdataDeclaration = CTypeSpec -> Ident -> CDecl
buildDeclaration (CTypeSpec -> Ident -> CDecl)
-> (Sing a -> CTypeSpec) -> Sing a -> Ident -> CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HMeasure a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HMeasure a) -> String)
-> (Sing a -> Sing ('HMeasure a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure

mdataPtrDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
mdataPtrDeclaration :: Sing a -> Ident -> CDecl
mdataPtrDeclaration = CTypeSpec -> Ident -> CDecl
buildPtrDeclaration (CTypeSpec -> Ident -> CDecl)
-> (Sing a -> CTypeSpec) -> Sing a -> Ident -> CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HMeasure a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HMeasure a) -> String)
-> (Sing a -> Sing ('HMeasure a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure

mdataWeight :: CExpr -> CExpr
mdataWeight :: CExpr -> CExpr
mdataWeight CExpr
d = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
d (String -> Ident
Ident String
"weight") Bool
True

mdataSample :: CExpr -> CExpr
mdataSample :: CExpr -> CExpr
mdataSample CExpr
d = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
d (String -> Ident
Ident String
"sample") Bool
True

mdataPtrWeight :: CExpr -> CExpr
mdataPtrWeight :: CExpr -> CExpr
mdataPtrWeight CExpr
d = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
d (String -> Ident
Ident String
"weight") Bool
False

mdataPtrSample :: CExpr -> CExpr
mdataPtrSample :: CExpr -> CExpr
mdataPtrSample CExpr
d = CExpr -> Ident -> Bool -> CExpr
CMember CExpr
d (String -> Ident
Ident String
"sample") Bool
False



--------------------------------------------------------------------------------
--                                     Datum                                  --
--------------------------------------------------------------------------------
{-
  In order to successfully represent Hakaru datum (Sums of Products of Hakaru
  types), we must have:

  > unique names for a given datum so if SVoid occurs twice in a program, C will
    be using the same structure

  > C structs

  > A datum may be recursive, so we will need to generate structures for all
    subtypes as well. These subtypes will need to be declared before the datum
    for the code to compile
-}

datumStruct :: (Sing (HData' t)) -> CExtDecl
datumStruct :: Sing (HData' t) -> CExtDecl
datumStruct dat :: Sing (HData' t)
dat@(SData _ typ)
  = CDecl -> CExtDecl
CDeclExt (CDecl -> CExtDecl) -> CDecl -> CExtDecl
forall a b. (a -> b) -> a -> b
$ Sing (HData' t) -> Sing (Code t) -> Ident -> CDecl
forall (t :: HakaruCon) (a :: [[HakaruFun]]).
Sing (HData' t) -> Sing a -> Ident -> CDecl
datumSum Sing (HData' t)
dat Sing (Code t)
Sing (Code t)
typ (String -> Ident
Ident (Sing (HData' t) -> String
forall (a :: Hakaru). Sing a -> String
typeName Sing (HData' t)
dat))

datumDeclaration
  :: (Sing (HData' t))
  -> Ident
  -> CDecl
datumDeclaration :: Sing (HData' t) -> Ident -> CDecl
datumDeclaration = CTypeSpec -> Ident -> CDecl
buildDeclaration (CTypeSpec -> Ident -> CDecl)
-> (Sing (HData' t) -> CTypeSpec)
-> Sing (HData' t)
-> Ident
-> CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CTypeSpec
callStruct (String -> CTypeSpec)
-> (Sing (HData' t) -> String) -> Sing (HData' t) -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing (HData' t) -> String
forall (a :: Hakaru). Sing a -> String
typeName

datumSum
  :: Sing (HData' t)
  -> Sing (a :: [[HakaruFun]])
  -> Ident
  -> CDecl
datumSum :: Sing (HData' t) -> Sing a -> Ident -> CDecl
datumSum Sing (HData' t)
dat Sing a
funs Ident
ident =
  let declrs :: [CDecl]
declrs = ([CDecl], [String]) -> [CDecl]
forall a b. (a, b) -> a
fst (([CDecl], [String]) -> [CDecl]) -> ([CDecl], [String]) -> [CDecl]
forall a b. (a -> b) -> a -> b
$ State [String] [CDecl] -> [String] -> ([CDecl], [String])
forall s a. State s a -> s -> (a, s)
runState (Sing (HData' t) -> Sing a -> State [String] [CDecl]
forall (t :: HakaruCon) (a :: [[HakaruFun]]).
Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumSum' Sing (HData' t)
dat Sing a
funs) [String]
cNameStream
      union :: CDecl
union  = CTypeSpec -> Ident -> CDecl
buildDeclaration ([CDecl] -> CTypeSpec
buildUnion [CDecl]
declrs) (String -> Ident
Ident String
"sum")
      ind :: CDecl
ind    = CTypeSpec -> Ident -> CDecl
buildDeclaration CTypeSpec
CInt (String -> Ident
Ident String
"index")
      struct :: CTypeSpec
struct = Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ident) ([CDecl] -> CTypeSpec) -> [CDecl] -> CTypeSpec
forall a b. (a -> b) -> a -> b
$ case [CDecl]
declrs of
                                            [] -> [CDecl
ind]
                                            [CDecl]
_  -> [CDecl
ind,CDecl
union]
  in [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [ CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
struct ] []

datumSum'
  :: Sing (HData' t)
  -> Sing (a :: [[HakaruFun]])
  -> State [String] [CDecl]
datumSum' :: Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumSum' Sing (HData' t)
_ Sing a
SVoid               = [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
datumSum' Sing (HData' t)
dat (SPlus prod rest) =
  do [String]
nn <- StateT [String] Identity [String]
forall s (m :: * -> *). MonadState s m => m s
get
     case [String]
nn of
      String
name:[String]
names -> do
       [String] -> StateT [String] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [String]
names
       let ident :: Ident
ident = String -> Ident
Ident String
name
           mdecl :: Maybe CDecl
mdecl = Sing (HData' t) -> Sing xs -> Ident -> Maybe CDecl
forall (t :: HakaruCon) (a :: [HakaruFun]).
Sing (HData' t) -> Sing a -> Ident -> Maybe CDecl
datumProd Sing (HData' t)
dat Sing xs
prod Ident
ident
       [CDecl]
rest' <- Sing (HData' t) -> Sing xss -> State [String] [CDecl]
forall (t :: HakaruCon) (a :: [[HakaruFun]]).
Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumSum' Sing (HData' t)
dat Sing xss
rest
       case Maybe CDecl
mdecl of
         Maybe CDecl
Nothing -> [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl]
rest'
         Just CDecl
d  -> [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CDecl] -> State [String] [CDecl])
-> [CDecl] -> State [String] [CDecl]
forall a b. (a -> b) -> a -> b
$ [CDecl
d] [CDecl] -> [CDecl] -> [CDecl]
forall a. [a] -> [a] -> [a]
++ [CDecl]
rest'

datumProd
  :: Sing (HData' t)
  -> Sing (a :: [HakaruFun])
  -> Ident
  -> Maybe CDecl
datumProd :: Sing (HData' t) -> Sing a -> Ident -> Maybe CDecl
datumProd Sing (HData' t)
_ Sing a
SDone Ident
_       = Maybe CDecl
forall a. Maybe a
Nothing
datumProd Sing (HData' t)
dat Sing a
funs Ident
ident  =
  let declrs :: [CDecl]
declrs = ([CDecl], [String]) -> [CDecl]
forall a b. (a, b) -> a
fst (([CDecl], [String]) -> [CDecl]) -> ([CDecl], [String]) -> [CDecl]
forall a b. (a -> b) -> a -> b
$ State [String] [CDecl] -> [String] -> ([CDecl], [String])
forall s a. State s a -> s -> (a, s)
runState (Sing (HData' t) -> Sing a -> State [String] [CDecl]
forall (t :: HakaruCon) (a :: [HakaruFun]).
Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumProd' Sing (HData' t)
dat Sing a
funs) [String]
cNameStream
  in  CDecl -> Maybe CDecl
forall a. a -> Maybe a
Just (CDecl -> Maybe CDecl) -> CDecl -> Maybe CDecl
forall a b. (a -> b) -> a -> b
$ CTypeSpec -> Ident -> CDecl
buildDeclaration (Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct Maybe Ident
forall a. Maybe a
Nothing ([CDecl] -> CTypeSpec) -> [CDecl] -> CTypeSpec
forall a b. (a -> b) -> a -> b
$ [CDecl]
declrs) Ident
ident

-- datumProd uses a store of names, which needs to match up with the names used
-- when they are assigned as well as printed
datumProd'
  :: Sing (HData' t)
  -> Sing (a :: [HakaruFun])
  -> State [String] [CDecl]
datumProd' :: Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumProd' Sing (HData' t)
_ Sing a
SDone        = [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
datumProd' Sing (HData' t)
dat (SEt x ps) =
  do [CDecl]
x'  <- Sing (HData' t) -> Sing x -> State [String] [CDecl]
forall (t :: HakaruCon) (a :: HakaruFun).
Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumPrim Sing (HData' t)
dat Sing x
x
     [CDecl]
ps' <- Sing (HData' t) -> Sing xs -> State [String] [CDecl]
forall (t :: HakaruCon) (a :: [HakaruFun]).
Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumProd' Sing (HData' t)
dat Sing xs
ps
     [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CDecl] -> State [String] [CDecl])
-> [CDecl] -> State [String] [CDecl]
forall a b. (a -> b) -> a -> b
$ [CDecl]
x' [CDecl] -> [CDecl] -> [CDecl]
forall a. [a] -> [a] -> [a]
++ [CDecl]
ps'

-- We need to pass HData in case it is some recursive type
datumPrim
  :: Sing (HData' t)
  -> Sing (a :: HakaruFun)
  -> State [String] [CDecl]
datumPrim :: Sing (HData' t) -> Sing a -> State [String] [CDecl]
datumPrim Sing (HData' t)
dat Sing a
prim =
  do [String]
nn <- StateT [String] Identity [String]
forall s (m :: * -> *). MonadState s m => m s
get
     case [String]
nn of
      (String
name:[String]
names) -> do
       [String] -> StateT [String] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [String]
names
       let ident :: Ident
ident = String -> Ident
Ident String
name
           decl :: CDecl
decl  = case Sing a
prim of
                     Sing a
SIdent     -> Sing (HData' t) -> Ident -> CDecl
forall (t :: HakaruCon). Sing (HData' t) -> Ident -> CDecl
datumDeclaration Sing (HData' t)
dat Ident
ident
                     (SKonst k) -> Sing a -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing a
k Ident
ident
       [CDecl] -> State [String] [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl
decl]

-- index into pair
datumFst :: CExpr -> CExpr
datumFst :: CExpr -> CExpr
datumFst CExpr
x = CExpr
x CExpr -> String -> CExpr
... String
"sum" CExpr -> String -> CExpr
... String
"a" CExpr -> String -> CExpr
... String
"a"

datumSnd :: CExpr -> CExpr
datumSnd :: CExpr -> CExpr
datumSnd CExpr
x = CExpr
x CExpr -> String -> CExpr
... String
"sum" CExpr -> String -> CExpr
... String
"a" CExpr -> String -> CExpr
... String
"b"

datumIndex :: CExpr -> CExpr
datumIndex :: CExpr -> CExpr
datumIndex CExpr
x = CExpr
x CExpr -> String -> CExpr
... String
"index"

--------------------------------------------------------------------------------
--                                Functions                                   --
--------------------------------------------------------------------------------
{-
   This still needs some work. Currently, we use the CodeGenMonad to give us
   a list of local declarations and statements to be used in a function. Then
   build a function from that.
-}

functionDef
  :: Sing (a :: Hakaru)
  -> Ident
  -> [CDecl]
  -> [CDecl]
  -> [CStat]
  -> CFunDef
functionDef :: Sing a -> Ident -> [CDecl] -> [CDecl] -> [CStat] -> CFunDef
functionDef Sing a
typ Ident
ident [CDecl]
argDecls [CDecl]
internalDecls [CStat]
stmts =
  [CDeclSpec] -> CDeclr -> [CDecl] -> CStat -> CFunDef
CFunDef ((CTypeSpec -> CDeclSpec) -> [CTypeSpec] -> [CDeclSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> CDeclSpec
CTypeSpec ([CTypeSpec] -> [CDeclSpec]) -> [CTypeSpec] -> [CDeclSpec]
forall a b. (a -> b) -> a -> b
$ Sing a -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing a
typ)
          (Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing (Ident -> CDirectDeclr
CDDeclrIdent Ident
ident))
          [CDecl]
argDecls
          ([CCompoundBlockItem] -> CStat
CCompound (((CDecl -> CCompoundBlockItem) -> [CDecl] -> [CCompoundBlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CDecl -> CCompoundBlockItem
CBlockDecl [CDecl]
internalDecls)
                   [CCompoundBlockItem]
-> [CCompoundBlockItem] -> [CCompoundBlockItem]
forall a. [a] -> [a] -> [a]
++ ((CStat -> CCompoundBlockItem) -> [CStat] -> [CCompoundBlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CStat -> CCompoundBlockItem
CBlockStat [CStat]
stmts)))

--------------
-- Closures --
--------------

-- externally declare closure structure
closureStructure
  :: forall (a :: Hakaru) xs
  .  [SomeVariable (KindOf a)]       -- ^ free variables
  -> List1 Variable (xs :: [Hakaru]) -- ^ function arguments
  -> Ident                           -- ^ identifier of function
  -> Sing a                          -- ^ function return type
  -> CExtDecl
closureStructure :: [SomeVariable (KindOf a)]
-> List1 Variable xs -> Ident -> Sing a -> CExtDecl
closureStructure [SomeVariable (KindOf a)]
fvs List1 Variable xs
as i :: Ident
i@(Ident String
name) Sing a
typ = CDecl -> CExtDecl
CDeclExt (CDecl -> CExtDecl) -> CDecl -> CExtDecl
forall a b. (a -> b) -> a -> b
$
  ([CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec (CTypeSpec -> CDeclSpec) -> CTypeSpec -> CDeclSpec
forall a b. (a -> b) -> a -> b
$ (Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
i) (CDecl
codePtrCDecl -> [CDecl] -> [CDecl]
forall a. a -> [a] -> [a]
:([String] -> [SomeVariable (KindOf a)] -> [CDecl]
forall (kproxy :: KProxy Hakaru).
[String] -> [SomeVariable kproxy] -> [CDecl]
declFvs [String]
cNameStream [SomeVariable (KindOf a)]
fvs)))]
         [])
  where declFvs :: [String] -> [SomeVariable kproxy] -> [CDecl]
declFvs [String]
_ [] = []
        declFvs (String
n:[String]
ns) ((SomeVariable (Variable Text
_ Nat
_ Sing a
typ')):[SomeVariable kproxy]
as') =
          Sing a -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing a
typ' (String -> Ident
Ident String
n) CDecl -> [CDecl] -> [CDecl]
forall a. a -> [a] -> [a]
: [String] -> [SomeVariable kproxy] -> [CDecl]
declFvs [String]
ns [SomeVariable kproxy]
as'
        declFvc :: [a] -> [a] -> a
declFvc [] (a
_:[a]
_) = String -> a
forall a. HasCallStack => String -> a
error String
"Ran out of identifiers but still had some types to assign"
        codePtr :: CDecl
codePtr = [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl ((CTypeSpec -> CDeclSpec) -> [CTypeSpec] -> [CDeclSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> CDeclSpec
CTypeSpec ([CTypeSpec] -> [CDeclSpec])
-> (Sing a -> [CTypeSpec]) -> Sing a -> [CDeclSpec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType (Sing a -> [CDeclSpec]) -> Sing a -> [CDeclSpec]
forall a b. (a -> b) -> a -> b
$ Sing a
typ)
                        [(Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing
                           (CDirectDeclr -> [[CTypeSpec]] -> CDirectDeclr
CDDeclrFun
                             (CDeclr -> CDirectDeclr
CDDeclrRec
                               (Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr (CPtrDeclr -> Maybe CPtrDeclr
forall a. a -> Maybe a
Just (CPtrDeclr -> Maybe CPtrDeclr)
-> ([CTypeQual] -> CPtrDeclr) -> [CTypeQual] -> Maybe CPtrDeclr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTypeQual] -> CPtrDeclr
CPtrDeclr ([CTypeQual] -> Maybe CPtrDeclr) -> [CTypeQual] -> Maybe CPtrDeclr
forall a b. (a -> b) -> a -> b
$ [])
                                       (Ident -> CDirectDeclr
CDDeclrIdent (Ident -> CDirectDeclr)
-> (String -> Ident) -> String -> CDirectDeclr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident (String -> CDirectDeclr) -> String -> CDirectDeclr
forall a b. (a -> b) -> a -> b
$ String
"_code_ptr")))
                             ([String -> CTypeSpec
callStruct String
name][CTypeSpec] -> [[CTypeSpec]] -> [[CTypeSpec]]
forall a. a -> [a] -> [a]
:(List1 Variable xs -> [[CTypeSpec]]
forall (xs :: [Hakaru]). List1 Variable xs -> [[CTypeSpec]]
varTypes List1 Variable xs
as)))
                         ,Maybe CInit
forall a. Maybe a
Nothing)]

        varTypes :: List1 Variable (xs :: [Hakaru]) -> [[CTypeSpec]]
        varTypes :: List1 Variable xs -> [[CTypeSpec]]
varTypes = (forall (i :: Hakaru). Variable i -> [[CTypeSpec]])
-> List1 Variable xs -> [[CTypeSpec]]
forall k1 k2 (f :: (k1 -> *) -> k2 -> *) m (a :: k1 -> *)
       (j :: k2).
(Foldable11 f, Monoid m) =>
(forall (i :: k1). a i -> m) -> f a j -> m
foldMap11 (\(Variable _ _ typ') -> [Sing i -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing i
typ'])



--------------------------------------------------------------------------------
-- | buildType function do the work of describing how the Hakaru
-- type will be stored in memory. Arrays needed their own
-- declaration function for their arity

buildType :: Sing (a :: Hakaru) -> [CTypeSpec]
buildType :: Sing a -> [CTypeSpec]
buildType Sing a
SInt          = [CTypeSpec
CInt]
buildType Sing a
SNat          = [CTypeSpec
CUnsigned, CTypeSpec
CInt]
buildType Sing a
SProb         = [CTypeSpec
CDouble]
buildType Sing a
SReal         = [CTypeSpec
CDouble]
buildType (SMeasure x)  = [String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HMeasure a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HMeasure a) -> String)
-> (Sing a -> Sing ('HMeasure a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing a -> CTypeSpec) -> Sing a -> CTypeSpec
forall a b. (a -> b) -> a -> b
$ Sing a
x]
buildType (SArray t)    = [String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HArray a) -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing ('HArray a) -> String)
-> (Sing a -> Sing ('HArray a)) -> Sing a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray (Sing a -> CTypeSpec) -> Sing a -> CTypeSpec
forall a b. (a -> b) -> a -> b
$ Sing a
t]
buildType (SFun _ x)    = Sing b -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType (Sing b -> [CTypeSpec]) -> Sing b -> [CTypeSpec]
forall a b. (a -> b) -> a -> b
$ Sing b
x -- build type the function returns
buildType d :: Sing a
d@(SData _ _) = [String -> CTypeSpec
callStruct (String -> CTypeSpec) -> (Sing a -> String) -> Sing a -> CTypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> String
forall (a :: Hakaru). Sing a -> String
typeName (Sing a -> CTypeSpec) -> Sing a -> CTypeSpec
forall a b. (a -> b) -> a -> b
$ Sing a
d]


-- these mk...Decl functions are used in coersions
castTo :: [CTypeSpec] -> CExpr -> CExpr
castTo :: [CTypeSpec] -> CExpr -> CExpr
castTo [CTypeSpec]
t = CTypeName -> CExpr -> CExpr
CCast ([CTypeSpec] -> Bool -> CTypeName
CTypeName [CTypeSpec]
t Bool
False)

castToPtrOf :: [CTypeSpec] -> CExpr -> CExpr
castToPtrOf :: [CTypeSpec] -> CExpr -> CExpr
castToPtrOf [CTypeSpec]
t = CTypeName -> CExpr -> CExpr
CCast ([CTypeSpec] -> Bool -> CTypeName
CTypeName [CTypeSpec]
t Bool
True)

buildStruct :: Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct :: Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct Maybe Ident
mi [CDecl]
decls =
  CSUSpec -> CTypeSpec
CSUType (CSUTag -> Maybe Ident -> [CDecl] -> CSUSpec
CSUSpec CSUTag
CStructTag Maybe Ident
mi [CDecl]
decls)

-- | callStruct will give the type spec calling a struct we have already
--   declared externally
callStruct :: String -> CTypeSpec
callStruct :: String -> CTypeSpec
callStruct String
name =
  CSUSpec -> CTypeSpec
CSUType (CSUTag -> Maybe Ident -> [CDecl] -> CSUSpec
CSUSpec CSUTag
CStructTag (Ident -> Maybe Ident
forall a. a -> Maybe a
Just (String -> Ident
Ident String
name)) [])

buildUnion :: [CDecl] -> CTypeSpec
buildUnion :: [CDecl] -> CTypeSpec
buildUnion [CDecl]
decls =
 CSUSpec -> CTypeSpec
CSUType (CSUTag -> Maybe Ident -> [CDecl] -> CSUSpec
CSUSpec CSUTag
CUnionTag Maybe Ident
forall a. Maybe a
Nothing [CDecl]
decls)


binaryOp :: NaryOp a -> CExpr -> CExpr -> CExpr
binaryOp :: NaryOp a -> CExpr -> CExpr -> CExpr
binaryOp (Sum HSemiring a
HSemiring_Prob)  CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CAddOp (CExpr -> CExpr
expE CExpr
a) (CExpr -> CExpr
expE CExpr
b)
binaryOp (Prod HSemiring a
HSemiring_Prob) CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CAddOp CExpr
a CExpr
b
binaryOp (Sum HSemiring a
_)               CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CAddOp CExpr
a CExpr
b
binaryOp (Prod HSemiring a
_)              CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CMulOp CExpr
a CExpr
b
-- vvv Operations on bools, keeping in mind that in Hakaru-C: 0 is true and 1 is false
binaryOp NaryOp a
And                   CExpr
a CExpr
b = CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CNegOp (CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CEqOp  CExpr
a CExpr
b) -- still wrong
binaryOp NaryOp a
Or                    CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CAndOp CExpr
a CExpr
b                 -- still wrong
binaryOp NaryOp a
Xor                   CExpr
a CExpr
b = CBinaryOp -> CExpr -> CExpr -> CExpr
CBinary CBinaryOp
CLorOp CExpr
a CExpr
b                 -- still wrong
binaryOp NaryOp a
x CExpr
_ CExpr
_ = String -> CExpr
forall a. HasCallStack => String -> a
error (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ String
"TODO: binaryOp " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NaryOp a -> String
forall a. Show a => a -> String
show NaryOp a
x