{-# LANGUAGE DataKinds,
             FlexibleContexts,
             GADTs,
             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

  -- functions and closures
  , functionDef
  , closureDeclaration

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

import Control.Monad.State

import Language.Hakaru.Syntax.AST
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 ctyp ident =
  CDecl [ CTypeSpec ctyp ]
        [( CDeclr Nothing (CDDeclrIdent ident)
         , Nothing)]

buildDeclaration' :: [CTypeSpec] -> Ident -> CDecl
buildDeclaration' specs ident =
  CDecl (fmap CTypeSpec specs)
        [( CDeclr Nothing (CDDeclrIdent ident)
         , Nothing)]

buildPtrDeclaration :: CTypeSpec -> Ident -> CDecl
buildPtrDeclaration ctyp ident =
  CDecl [ CTypeSpec ctyp ]
        [( CDeclr (Just $ CPtrDeclr []) (CDDeclrIdent ident)
         , Nothing)]

typeDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typeDeclaration typ ident =
  CDecl (fmap CTypeSpec $ buildType typ)
        [( CDeclr Nothing (CDDeclrIdent ident)
         , Nothing)]

typePtrDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typePtrDeclaration typ ident =
  CDecl (fmap CTypeSpec $ buildType typ)
        [( CDeclr (Just $ CPtrDeclr [])
                  (CDDeclrIdent ident)
         , 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 SInt         = "int"
typeName SNat         = "nat"
typeName SReal        = "real"
typeName SProb        = "prob"
typeName (SArray t)   = "array_" ++ typeName t
typeName (SMeasure t) = "mdata_" ++ typeName t
typeName f@(SFun _ _)  = error $ "typeName{SFun} doen't make sense: unknown context for {" ++ show f ++ "}"
typeName (SData _ t)  = "dat_" ++ datumSumName t
  where datumSumName :: Sing (a :: [[HakaruFun]]) -> String
        datumSumName SVoid = "V"
        datumSumName (SPlus p s) = datumProdName p ++ datumSumName s

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

        datumPrimName :: Sing (a :: HakaruFun) -> String
        datumPrimName SIdent = "I"
        datumPrimName (SKonst s) = "K" ++ typeName 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 t = CDeclExt (CDecl [CTypeSpec $ arrayStruct' t] [])

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


arrayDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
arrayDeclaration = buildDeclaration . callStruct . typeName . SArray


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

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

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

arrayPtrData :: CExpr -> CExpr
arrayPtrData e = CMember e (Ident "data") 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 t = CDeclExt (CDecl [CTypeSpec $ mdataStruct' t] [])

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

mdataDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
mdataDeclaration = buildDeclaration . callStruct . typeName . SMeasure

mdataPtrDeclaration
  :: Sing (a :: Hakaru)
  -> Ident
  -> CDecl
mdataPtrDeclaration = buildPtrDeclaration . callStruct . typeName . SMeasure

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

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

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

mdataPtrSample :: CExpr -> CExpr
mdataPtrSample d = CMember d (Ident "sample") 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 dat@(SData _ typ)
  = CDeclExt $ datumSum dat typ (Ident (typeName dat))

datumDeclaration
  :: (Sing (HData' t))
  -> Ident
  -> CDecl
datumDeclaration = buildDeclaration . callStruct . typeName

datumSum
  :: Sing (HData' t)
  -> Sing (a :: [[HakaruFun]])
  -> Ident
  -> CDecl
datumSum dat funs ident =
  let declrs = fst $ runState (datumSum' dat funs) cNameStream
      union  = buildDeclaration (buildUnion declrs) (Ident "sum")
      index  = buildDeclaration CInt (Ident "index")
      struct = buildStruct (Just ident) $ case declrs of
                                            [] -> [index]
                                            _  -> [index,union]
  in CDecl [ CTypeSpec struct ] []

datumSum'
  :: Sing (HData' t)
  -> Sing (a :: [[HakaruFun]])
  -> State [String] [CDecl]
datumSum' _ SVoid               = return []
datumSum' dat (SPlus prod rest) =
  do (name:names) <- get
     put names
     let ident = Ident name
         mdecl = datumProd dat prod ident
     rest' <- datumSum' dat rest
     case mdecl of
       Nothing -> return rest'
       Just d  -> return $ [d] ++ rest'

datumProd
  :: Sing (HData' t)
  -> Sing (a :: [HakaruFun])
  -> Ident
  -> Maybe CDecl
datumProd _ SDone _       = Nothing
datumProd dat funs ident  =
  let declrs = fst $ runState (datumProd' dat funs) cNameStream
  in  Just $ buildDeclaration (buildStruct Nothing $ declrs) 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' _ SDone        = return []
datumProd' dat (SEt x ps) =
  do x'  <- datumPrim dat x
     ps' <- datumProd' dat ps
     return $ x' ++ ps'

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

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

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

--------------------------------------------------------------------------------
--                                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 typ ident argDecls internalDecls stmts =
  CFunDef (fmap CTypeSpec $ buildType typ)
          (CDeclr Nothing (CDDeclrIdent ident))
          argDecls
          (CCompound ((fmap CBlockDecl internalDecls)
                   ++ (fmap CBlockStat stmts)))

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

closureDeclaration
  :: (Sing (a :: Hakaru))
  -> Ident
  -> CDecl
closureDeclaration = buildDeclaration . callStruct . typeName



--------------------------------------------------------------------------------
-- | 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 SInt          = [CInt]
buildType SNat          = [CUnsigned, CInt]
buildType SProb         = [CDouble]
buildType SReal         = [CDouble]
buildType (SMeasure x)  = [callStruct . typeName . SMeasure $ x]
buildType (SArray t)    = [callStruct . typeName . SArray $ t]
buildType (SFun _ x)    = buildType $ x -- build type the function returns
buildType d@(SData _ _) = [callStruct . typeName $ d]


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

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

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

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

buildUnion :: [CDecl] -> CTypeSpec
buildUnion decls =
 CSUType (CSUSpec CUnionTag Nothing decls)


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