{-# LANGUAGE BangPatterns,
             CPP,
             OverloadedStrings,
             DataKinds,
             FlexibleContexts,
             GADTs,
             KindSignatures,
             RankNTypes,
             ScopedTypeVariables,
             TypeOperators #-}

----------------------------------------------------------------
--                                                    2016.06.23
-- |
-- Module      :  Language.Hakaru.CodeGen.Wrapper
-- Copyright   :  Copyright (c) 2016 the Hakaru team
-- License     :  BSD3
-- Maintainer  :  zsulliva@indiana.edu
-- Stability   :  experimental
-- Portability :  GHC-only
--
--   The purpose of the wrapper is to intelligently wrap CStatements
-- into CFunctions and CProgroms to be printed by 'hkc'
--
----------------------------------------------------------------


module Language.Hakaru.CodeGen.Wrapper
  ( wrapProgram
  , PrintConfig(..)
  ) where

import           Language.Hakaru.Syntax.ABT
import           Language.Hakaru.Syntax.AST
import           Language.Hakaru.Syntax.IClasses
import           Language.Hakaru.Syntax.TypeCheck
import           Language.Hakaru.Syntax.TypeOf (typeOf)
import           Language.Hakaru.Types.Sing
import           Language.Hakaru.CodeGen.CodeGenMonad
import           Language.Hakaru.CodeGen.Flatten
import           Language.Hakaru.CodeGen.Types
import           Language.Hakaru.CodeGen.AST
import           Language.Hakaru.CodeGen.Libs
import           Language.Hakaru.Types.DataKind (Hakaru(..))
import           Control.Monad.State.Strict
import           Prelude            as P hiding (unlines,exp)


#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
#endif


-- | wrapProgram is the top level C codegen. Depending on the type a program
--   will have a different construction. It will produce an effect in the
--   CodeGenMonad that will produce a standalone C file containing the CPP
--   includes, struct declarations, functions, and sometimes a main.
wrapProgram
  :: TypedAST (TrivialABT Term) -- ^ Some Hakaru ABT
  -> Maybe String               -- ^ Maybe an output name
  -> PrintConfig                -- ^ show weights?
  -> CodeGen ()
wrapProgram :: TypedAST (TrivialABT Term)
-> Maybe String -> PrintConfig -> CodeGen ()
wrapProgram tast :: TypedAST (TrivialABT Term)
tast@(TypedAST Sing b
typ TrivialABT Term '[] b
_) Maybe String
mn PrintConfig
pconfig =
  do [CodeGen ()] -> CodeGen ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([CodeGen ()] -> CodeGen ())
-> (Sing b -> [CodeGen ()]) -> Sing b -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Preprocessor -> CodeGen ()) -> [Preprocessor] -> [CodeGen ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CExtDecl -> CodeGen ()
extDeclare (CExtDecl -> CodeGen ())
-> (Preprocessor -> CExtDecl) -> Preprocessor -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Preprocessor -> CExtDecl
CPPExt) ([Preprocessor] -> [CodeGen ()])
-> (Sing b -> [Preprocessor]) -> Sing b -> [CodeGen ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing b -> [Preprocessor]
forall (a :: Hakaru). Sing a -> [Preprocessor]
header (Sing b -> CodeGen ()) -> Sing b -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Sing b
typ
     CG
cg <- StateT CG Identity CG
forall s (m :: * -> *). MonadState s m => m s
get
     Bool -> CodeGen () -> CodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CG -> Bool
managedMem CG
cg)  (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExtDecl -> CodeGen ()
extDeclare (CExtDecl -> CodeGen ())
-> (Preprocessor -> CExtDecl) -> Preprocessor -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Preprocessor -> CExtDecl
CPPExt (Preprocessor -> CodeGen ()) -> Preprocessor -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Preprocessor
gcHeader
     Bool -> CodeGen () -> CodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CG -> Bool
sharedMem CG
cg)   (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExtDecl -> CodeGen ()
extDeclare (CExtDecl -> CodeGen ())
-> (Preprocessor -> CExtDecl) -> Preprocessor -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Preprocessor -> CExtDecl
CPPExt (Preprocessor -> CodeGen ()) -> Preprocessor -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Preprocessor
openMpHeader
     case (TypedAST (TrivialABT Term)
tast,Maybe String
mn) of
       ( TypedAST (SFun _ _) TrivialABT Term '[] b
abt, Just String
name ) ->
         TrivialABT Term '[] b -> Ident -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Ident -> CodeGen ()
flattenTopLambda TrivialABT Term '[] b
abt (Ident -> CodeGen ()) -> StateT CG Identity Ident -> CodeGen ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> StateT CG Identity Ident
reserveIdent String
name

       ( TypedAST Sing b
typ' TrivialABT Term '[] b
abt,       Just String
name ) ->
         -- still buggy for measures
         do Ident
mfId <- String -> StateT CG Identity Ident
reserveIdent String
name
            [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG (Sing b -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing b
typ') Ident
mfId [] (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
              do CExpr
outE <- TrivialABT Term '[] b -> String -> CodeGen CExpr
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> String -> CodeGen CExpr
flattenWithName' TrivialABT Term '[] b
abt String
"out"
                 CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
outE

       ( TypedAST Sing b
typ'       TrivialABT Term '[] b
abt, Maybe String
Nothing   ) ->
         PrintConfig -> Sing b -> TrivialABT Term '[] b -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
PrintConfig -> Sing a -> abt '[] a -> CodeGen ()
mainFunction PrintConfig
pconfig Sing b
typ' TrivialABT Term '[] b
abt



header :: Sing (a :: Hakaru) -> [Preprocessor]
header :: Sing a -> [Preprocessor]
header (SMeasure _) = (String -> Preprocessor) -> [String] -> [Preprocessor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Preprocessor
PPInclude [String
"time.h", String
"stdlib.h", String
"stdio.h", String
"math.h"]
header Sing a
_            = (String -> Preprocessor) -> [String] -> [Preprocessor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Preprocessor
PPInclude [String
"stdlib.h", String
"stdio.h", String
"math.h"]



--------------------------------------------------------------------------------
--                             A Main Function                                --
--------------------------------------------------------------------------------
{-

Create standalone C program for a Hakaru ABT. This program will also print the
computed value to stdin.

-}

mainFunction
  :: ABT Term abt
  => PrintConfig
  -> Sing (a :: Hakaru)    -- ^ type of program
  -> abt '[] (a :: Hakaru) -- ^ Hakaru ABT
  -> CodeGen ()

-- when measure, compile to a sampler
mainFunction :: PrintConfig -> Sing a -> abt '[] a -> CodeGen ()
mainFunction PrintConfig
pconfig typ :: Sing a
typ@(SMeasure _) abt '[] a
abt =
  do Ident
mfId    <- String -> StateT CG Identity Ident
reserveIdent String
"measure"
     Ident
mainId  <- String -> StateT CG Identity Ident
reserveIdent String
"main"
     Ident
argVId <- String -> StateT CG Identity Ident
reserveIdent String
"argv"
     Ident
argCId <- String -> StateT CG Identity Ident
reserveIdent String
"argc"
     let (CExpr
argCE:CExpr
argVE:[]) = (Ident -> CExpr) -> [Ident] -> [CExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> CExpr
CVar [Ident
argCId,Ident
argVId]
     Sing a -> CodeGen ()
forall (a :: Hakaru). Sing a -> CodeGen ()
extDeclareTypes Sing a
typ

     -- defined a measure function that returns mdata
     [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG (Sing a -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing a
typ) Ident
mfId  [] (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
       (CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just) (CExpr -> CodeGen ()) -> CodeGen CExpr -> CodeGen ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< abt '[] a -> String -> CodeGen CExpr
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> String -> CodeGen CExpr
flattenWithName' abt '[] a
abt String
"samp"

     [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG [CTypeSpec
CInt] Ident
mainId [CDecl]
mainArgs (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
       do Bool
isManagedMem <- CG -> Bool
managedMem (CG -> Bool) -> StateT CG Identity CG -> StateT CG Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CG Identity CG
forall s (m :: * -> *). MonadState s m => m s
get
          Bool -> CodeGen () -> CodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isManagedMem (CExpr -> CodeGen ()
putExprStat CExpr
gcInit)

          CExpr
nSamples <- CExpr -> CExpr -> CodeGen CExpr
parseNumSamples CExpr
argCE CExpr
argVE
          CExpr
seedE <- CExpr -> CExpr -> CodeGen CExpr
parseSeed CExpr
argCE CExpr
argVE

          CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> [CExpr] -> CExpr
mkCallE String
"srand" [CExpr
seedE]

          CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Run Hakaru Sampler"
          PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing a
typ (CExpr -> [CExpr] -> CExpr
CCall (Ident -> CExpr
CVar Ident
mfId) []) (CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just CExpr
nSamples)
          CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Integer -> CExpr
intE Integer
0

mainFunction PrintConfig
pconfig (SFun _ _) abt '[] a
abt =
  abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> CodeGen ())
-> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
coalesceLambda abt '[] a
abt ((forall (ys :: [Hakaru]) (b :: Hakaru).
  List1 Variable ys -> abt '[] b -> CodeGen ())
 -> CodeGen ())
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> CodeGen ())
-> CodeGen ()
forall a b. (a -> b) -> a -> b
$ \List1 Variable ys
_ abt '[] b
abt' ->
    do Ident
resId  <- String -> StateT CG Identity Ident
reserveIdent String
"result"
       Ident
mainId <- String -> StateT CG Identity Ident
reserveIdent String
"main"
       Ident
argVId <- String -> StateT CG Identity Ident
reserveIdent String
"argv"
       Ident
argCId <- String -> StateT CG Identity Ident
reserveIdent String
"argc"
       Ident
funId  <- String -> StateT CG Identity Ident
genIdent' String
"fn"
       abt '[] a -> Ident -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Ident -> CodeGen ()
flattenTopLambda abt '[] a
abt Ident
funId
       let (CExpr
resE:CExpr
funE:CExpr
argCE:CExpr
argVE:[]) = (Ident -> CExpr) -> [Ident] -> [CExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> CExpr
CVar [Ident
resId,Ident
funId,Ident
argCId,Ident
argVId]
           typ' :: Sing b
typ' = abt '[] b -> Sing b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt '[] b
abt'

       [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG [CTypeSpec
CInt] Ident
mainId [CDecl]
mainArgs (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
         do Bool
isManagedMem <- CG -> Bool
managedMem (CG -> Bool) -> StateT CG Identity CG -> StateT CG Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CG Identity CG
forall s (m :: * -> *). MonadState s m => m s
get
            Bool -> CodeGen () -> CodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isManagedMem (CExpr -> CodeGen ()
putExprStat CExpr
gcInit)
            Sing b -> Ident -> CodeGen ()
forall (a :: Hakaru). Sing a -> Ident -> CodeGen ()
declare Sing b
typ' Ident
resId

            Maybe CExpr
mns <- CExpr -> CExpr -> Sing b -> CodeGen (Maybe CExpr)
forall (a :: Hakaru).
CExpr -> CExpr -> Sing a -> CodeGen (Maybe CExpr)
maybeNumSamples CExpr
argCE CExpr
argVE Sing b
typ'
            case Sing b
typ' of
              SMeasure _ -> do CExpr
seedE <- CExpr -> CExpr -> CodeGen CExpr
parseSeed CExpr
argCE CExpr
argVE
                               CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> [CExpr] -> CExpr
mkCallE String
"srand" [CExpr
seedE]
              Sing b
_ -> () -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            Integer -> abt '[] a -> (Integer -> CodeGen ()) -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Integer -> abt '[] a -> (Integer -> CodeGen ()) -> CodeGen ()
withLambdaDepth' Integer
0 abt '[] a
abt ((Integer -> CodeGen ()) -> CodeGen ())
-> (Integer -> CodeGen ()) -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ \Integer
d ->
              let argErr :: a -> String
argErr a
0 = String
""
                  argErr a
n = (a -> String
argErr (a -> a
forall a. Enum a => a -> a
pred a
n)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"<arg" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"> " in
                CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG (CExpr
argCE CExpr -> CExpr -> CExpr
.<. (Integer -> CExpr
intE (Integer
dInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)))
                     (do CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE
                           [ String -> CExpr
stringE (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ String
"Usage: %s " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. (Eq a, Num a, Enum a, Show a) => a -> String
argErr Integer
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                           , (CExpr -> CExpr -> CExpr
index CExpr
argVE (Integer -> CExpr
intE Integer
0)) ]
                         CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> [CExpr] -> CExpr
mkCallE String
"abort" [ ])
                     (() -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

            CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Parse Args"
            [CExpr]
argEs <- Integer
-> abt '[] a
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Integer
-> abt '[] a
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
foldLambdaWithIndex Integer
1 abt '[] a
abt ((forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
 -> CodeGen [CExpr])
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
forall a b. (a -> b) -> a -> b
$ \Integer
i (Variable Text
_ Nat
_ Sing x
t) ->
                       do CExpr
argE <- Sing x -> String -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> String -> CodeGen CExpr
localVar' Sing x
t String
"arg"
                          CExpr
_ <- Sing x -> CExpr -> CExpr -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CExpr -> CExpr -> CodeGen CExpr
parseCG Sing x
t (CExpr -> CExpr -> CExpr
index CExpr
argVE (Integer -> CExpr
intE Integer
i)) CExpr
argE
                          CExpr -> CodeGen CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
argE

            case Sing b
typ' of
              SMeasure _ -> do CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Run Hakaru Sampler"
                               PrintConfig -> Sing b -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing b
typ' (CExpr -> [CExpr] -> CExpr
CCall CExpr
funE [CExpr]
argEs) Maybe CExpr
mns

              Sing b
_ -> do CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Run Hakaru Program"
                      CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
resE CExpr -> CExpr -> CExpr
.=. (CExpr -> [CExpr] -> CExpr
CCall CExpr
funE [CExpr]
argEs)
                      CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Print Result"
                      PrintConfig -> Sing b -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing b
typ' CExpr
resE Maybe CExpr
mns

            CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Integer -> CExpr
intE Integer
0


  where withLambdaDepth'
          :: ABT Term abt
          => Integer
          -> abt '[] a
          -> (Integer -> CodeGen ())
          -> CodeGen ()
        withLambdaDepth' :: Integer -> abt '[] a -> (Integer -> CodeGen ()) -> CodeGen ()
withLambdaDepth' Integer
n abt '[] a
abt_ Integer -> CodeGen ()
k =
          abt '[] a
-> (Variable a -> CodeGen ())
-> (Term abt a -> CodeGen ())
-> CodeGen ()
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn abt '[] a
abt_
            (CodeGen () -> Variable a -> CodeGen ()
forall a b. a -> b -> a
const (Integer -> CodeGen ()
k Integer
n))
            (\Term abt a
term ->
              case Term abt a
term of
                (SCon args a
Lam_ :$ abt vars a
body :* SArgs abt args
End) ->
                  abt '[a] a -> (Variable a -> abt '[] a -> CodeGen ()) -> CodeGen ()
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
body ((Variable a -> abt '[] a -> CodeGen ()) -> CodeGen ())
-> (Variable a -> abt '[] a -> CodeGen ()) -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ \Variable a
_ abt '[] a
abt_' ->
                    Integer -> abt '[] a -> (Integer -> CodeGen ()) -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Integer -> abt '[] a -> (Integer -> CodeGen ()) -> CodeGen ()
withLambdaDepth' (Integer -> Integer
forall a. Enum a => a -> a
succ Integer
n) abt '[] a
abt_' Integer -> CodeGen ()
k
                Term abt a
_ -> Integer -> CodeGen ()
k Integer
n)

        maybeNumSamples
          :: CExpr -> CExpr -> Sing (a :: Hakaru) -> CodeGen (Maybe CExpr)
        maybeNumSamples :: CExpr -> CExpr -> Sing a -> CodeGen (Maybe CExpr)
maybeNumSamples CExpr
c CExpr
v (SMeasure _) = CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> Maybe CExpr) -> CodeGen CExpr -> CodeGen (Maybe CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CExpr -> CExpr -> CodeGen CExpr
parseNumSamples CExpr
c CExpr
v
        maybeNumSamples CExpr
_ CExpr
_ Sing a
_ = Maybe CExpr -> CodeGen (Maybe CExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CExpr
forall a. Maybe a
Nothing

-- just a computation
mainFunction PrintConfig
pconfig Sing a
typ abt '[] a
abt =
  do Ident
resId  <- String -> StateT CG Identity Ident
reserveIdent String
"result"
     Ident
mainId <- String -> StateT CG Identity Ident
reserveIdent String
"main"
     let resE :: CExpr
resE  = Ident -> CExpr
CVar Ident
resId

     [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG [CTypeSpec
CInt] Ident
mainId [] (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
       do Sing a -> Ident -> CodeGen ()
forall (a :: Hakaru). Sing a -> Ident -> CodeGen ()
declare Sing a
typ Ident
resId

          Bool
isManagedMem <- CG -> Bool
managedMem (CG -> Bool) -> StateT CG Identity CG -> StateT CG Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CG Identity CG
forall s (m :: * -> *). MonadState s m => m s
get
          Bool -> CodeGen () -> CodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isManagedMem (CExpr -> CodeGen ()
putExprStat CExpr
gcInit)

          abt '[] a -> CExpr -> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> CExpr -> CodeGen ()
flattenABT abt '[] a
abt CExpr
resE
          PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing a
typ CExpr
resE Maybe CExpr
forall a. Maybe a
Nothing
          CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Integer -> CExpr
intE Integer
0

mainArgs :: [CDecl]
mainArgs :: [CDecl]
mainArgs = [ [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
CInt]
                   [(Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing (Ident -> CDirectDeclr
CDDeclrIdent (String -> Ident
Ident String
"argc")), Maybe CInit
forall a. Maybe a
Nothing)]
           , [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
CChar]
                   [(Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr (CPtrDeclr -> Maybe CPtrDeclr
forall a. a -> Maybe a
Just ([CTypeQual] -> CPtrDeclr
CPtrDeclr []))
                            (CDirectDeclr -> Maybe CExpr -> CDirectDeclr
CDDeclrArr (Ident -> CDirectDeclr
CDDeclrIdent (String -> Ident
Ident String
"argv")) Maybe CExpr
forall a. Maybe a
Nothing)
                     , Maybe CInit
forall a. Maybe a
Nothing)]
           ]

{- the number of samples is set to -1 by default -}
parseNumSamples :: CExpr -> CExpr -> CodeGen CExpr
parseNumSamples :: CExpr -> CExpr -> CodeGen CExpr
parseNumSamples CExpr
argc CExpr
argv =
  do CExpr
itE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CExpr
outE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Num Samples?"
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
outE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE (-Integer
1))
     CExpr -> CExpr -> CExpr -> CodeGen () -> CodeGen ()
forCG (CExpr
itE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE Integer
1))
           (CExpr
itE CExpr -> CExpr -> CExpr
.<. CExpr
argc)
           (CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostIncOp CExpr
itE)
           (CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG ((CExpr -> CExpr -> CExpr
index (CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE) (Integer -> CExpr
intE Integer
0) CExpr -> CExpr -> CExpr
.==. (Char -> CExpr
charE Char
'-')) CExpr -> CExpr -> CExpr
.&&.
                  (CExpr -> CExpr -> CExpr
index (CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE) (Integer -> CExpr
intE Integer
1) CExpr -> CExpr -> CExpr
.==. (Char -> CExpr
charE Char
'n')))
                 (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
                   [CExpr] -> CExpr
sscanfE [CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE,String -> CExpr
stringE String
"-n%d",CExpr -> CExpr
address CExpr
outE])
                 (() -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
     CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"End Num Samples?"
     CExpr -> CodeGen CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
outE

{- the randome seed is set to time(NULL) by default -}
parseSeed :: CExpr -> CExpr -> CodeGen CExpr
parseSeed :: CExpr -> CExpr -> CodeGen CExpr
parseSeed CExpr
argc CExpr
argv =
  do CExpr
itE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CExpr
outE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"Random Seed?"
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
outE CExpr -> CExpr -> CExpr
.=. (String -> [CExpr] -> CExpr
mkCallE String
"time" [ Ident -> CExpr
CVar (Ident -> CExpr) -> (String -> Ident) -> String -> CExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ String
"NULL"])
     CExpr -> CExpr -> CExpr -> CodeGen () -> CodeGen ()
forCG (CExpr
itE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE Integer
1))
           (CExpr
itE CExpr -> CExpr -> CExpr
.<. CExpr
argc)
           (CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostIncOp CExpr
itE)
           (CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG ((CExpr -> CExpr -> CExpr
index (CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE) (Integer -> CExpr
intE Integer
0) CExpr -> CExpr -> CExpr
.==. (Char -> CExpr
charE Char
'-')) CExpr -> CExpr -> CExpr
.&&.
                  (CExpr -> CExpr -> CExpr
index (CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE) (Integer -> CExpr
intE Integer
1) CExpr -> CExpr -> CExpr
.==. (Char -> CExpr
charE Char
's')))
                 (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
                   [CExpr] -> CExpr
sscanfE [CExpr -> CExpr -> CExpr
index CExpr
argv CExpr
itE,String -> CExpr
stringE String
"-s%d",CExpr -> CExpr
address CExpr
outE])
                 (() -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
     CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> CStat -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ String -> CStat
opComment String
"End Random Seed?"
     CExpr -> CodeGen CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
outE


--------------------------------------------------------------------------------
--                               Parsing Values                               --
--------------------------------------------------------------------------------

parseCG :: Sing (a :: Hakaru) -> CExpr -> CExpr -> CodeGen CExpr
parseCG :: Sing a -> CExpr -> CExpr -> CodeGen CExpr
parseCG (SArray t) CExpr
from CExpr
to =
  do Ident
fpId <- String -> StateT CG Identity Ident
genIdent' String
"fp"
     Ident
buffId <- String -> StateT CG Identity Ident
genIdent' String
"buff"
     CDecl -> CodeGen ()
declare' (CDecl -> CodeGen ()) -> CDecl -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
fileT]
                      [(Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr (CPtrDeclr -> Maybe CPtrDeclr
forall a. a -> Maybe a
Just ([CTypeQual] -> CPtrDeclr
CPtrDeclr []))
                               (Ident -> CDirectDeclr
CDDeclrIdent Ident
fpId)
                               , Maybe CInit
forall a. Maybe a
Nothing)]
     CDecl -> CodeGen ()
declare' (CDecl -> CodeGen ()) -> CDecl -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CDeclSpec] -> [(CDeclr, Maybe CInit)] -> CDecl
CDecl [CTypeSpec -> CDeclSpec
CTypeSpec CTypeSpec
CChar]
                      [(Maybe CPtrDeclr -> CDirectDeclr -> CDeclr
CDeclr Maybe CPtrDeclr
forall a. Maybe a
Nothing
                               (CDirectDeclr -> Maybe CExpr -> CDirectDeclr
CDDeclrArr (Ident -> CDirectDeclr
CDDeclrIdent Ident
buffId) (CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (Integer -> CExpr
intE Integer
1024)))
                               , Maybe CInit
forall a. Maybe a
Nothing)]
     let fpE :: CExpr
fpE = Ident -> CExpr
CVar Ident
fpId
         buffE :: CExpr
buffE = Ident -> CExpr
CVar Ident
buffId
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
fpE CExpr -> CExpr -> CExpr
.=. (CExpr -> CExpr -> CExpr
fopenE CExpr
from (String -> CExpr
stringE String
"r"))
     CExpr
itE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
itE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE Integer
0)
     CExpr -> CodeGen () -> CodeGen ()
whileCG (CExpr -> CExpr -> CExpr -> CExpr
fgetsE CExpr
buffE (Integer -> CExpr
intE Integer
1024) CExpr
fpE CExpr -> CExpr -> CExpr
.!=. CExpr
nullE)
             (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostIncOp CExpr
itE)
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr -> CExpr
arraySize CExpr
to CExpr -> CExpr -> CExpr
.=. CExpr
itE
     CExpr -> CExpr -> Sing a -> CodeGen ()
forall (a :: Hakaru). CExpr -> CExpr -> Sing a -> CodeGen ()
putMallocStat (CExpr -> CExpr
arrayData CExpr
to) CExpr
itE Sing a
t
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
itE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE Integer
0)
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr -> CExpr
rewindE CExpr
fpE
     CExpr -> CodeGen () -> CodeGen ()
whileCG (CExpr -> CExpr -> CExpr -> CExpr
fgetsE CExpr
buffE (Integer -> CExpr
intE Integer
1024) CExpr
fpE CExpr -> CExpr -> CExpr
.!=. CExpr
nullE)
             (do CExpr
checkE <- Sing a -> CExpr -> CExpr -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CExpr -> CExpr -> CodeGen CExpr
parseCG Sing a
t CExpr
buffE (CExpr -> CExpr -> CExpr
index (CExpr -> CExpr
arrayData CExpr
to) CExpr
itE)
                 CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG (CExpr
checkE CExpr -> CExpr -> CExpr
.==. (Integer -> CExpr
intE Integer
1))
                      (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostIncOp CExpr
itE)
                      (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostDecOp (CExpr -> CExpr
arraySize CExpr
to)))
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr -> CExpr
fcloseE CExpr
fpE
     Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat

parseCG Sing a
t CExpr
from CExpr
to =
  do CExpr
checkE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
checkE CExpr -> CExpr -> CExpr
.=. [CExpr] -> CExpr
sscanfE [CExpr
from,String -> CExpr
stringE (String -> CExpr) -> (Sing a -> String) -> Sing a -> CExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing a -> String
forall (a :: Hakaru). Sing a -> String
parseFormat (Sing a -> CExpr) -> Sing a -> CExpr
forall a b. (a -> b) -> a -> b
$ Sing a
t,CExpr -> CExpr
address CExpr
to]
     case Sing a
t of
       Sing a
SProb -> CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
to CExpr -> CExpr -> CExpr
.=. CExpr -> CExpr
logE CExpr
to
       Sing a
_ -> () -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     CExpr -> CodeGen CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
checkE

parseFormat :: Sing (a :: Hakaru) -> String
parseFormat :: Sing a -> String
parseFormat Sing a
SInt  = String
"%d"
parseFormat Sing a
SNat  = String
"%u"
parseFormat Sing a
SReal = String
"%lf"
parseFormat Sing a
SProb = String
"%lf"
parseFormat Sing a
t = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"parseCG{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sing a -> String
forall a. Show a => a -> String
show Sing a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}: no available parsing form"


--------------------------------------------------------------------------------
--                               Printing Values                              --
--------------------------------------------------------------------------------
{-

In HKC the printconfig is parsed from the command line. The default being that
we don't show weights and probabilities are printed as normal real values.

-}

data PrintConfig
  = PrintConfig { PrintConfig -> Bool
noWeights   :: Bool
                , PrintConfig -> Bool
showProbInLog :: Bool
                } deriving Int -> PrintConfig -> String -> String
[PrintConfig] -> String -> String
PrintConfig -> String
(Int -> PrintConfig -> String -> String)
-> (PrintConfig -> String)
-> ([PrintConfig] -> String -> String)
-> Show PrintConfig
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PrintConfig] -> String -> String
$cshowList :: [PrintConfig] -> String -> String
show :: PrintConfig -> String
$cshow :: PrintConfig -> String
showsPrec :: Int -> PrintConfig -> String -> String
$cshowsPrec :: Int -> PrintConfig -> String -> String
Show


printCG
  :: PrintConfig
  -> Sing (a :: Hakaru) -- ^ Hakaru type to be printed
  -> CExpr              -- ^ CExpr representing value
  -> Maybe CExpr        -- ^ If measure type, expr for num samples
  -> CodeGen ()
printCG :: PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig mtyp :: Sing a
mtyp@(SMeasure typ) CExpr
sampleFunc (Just CExpr
numSamples) =
  do CExpr
mE <- Sing a -> String -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> String -> CodeGen CExpr
localVar' Sing a
mtyp String
"m"
     CExpr
itE <- Sing 'HNat -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> CodeGen CExpr
localVar Sing 'HNat
SNat
     CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
itE CExpr -> CExpr -> CExpr
.=. CExpr
numSamples
     CExpr -> CodeGen () -> CodeGen ()
whileCG (CExpr
itE CExpr -> CExpr -> CExpr
.!=. (Integer -> CExpr
intE Integer
0)) (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
       do CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CExpr
mE CExpr -> CExpr -> CExpr
.=. CExpr
sampleFunc
          case PrintConfig -> Bool
noWeights PrintConfig
pconfig of
            Bool
True  -> PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing a
typ (CExpr -> CExpr
mdataSample CExpr
mE) Maybe CExpr
forall a. Maybe a
Nothing
            Bool
False -> do CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
                          [CExpr] -> CExpr
printfE [ String -> CExpr
stringE (PrintConfig -> Sing 'HProb -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
pconfig Sing 'HProb
SProb String
"\t")
                                  , CExpr -> CExpr
expE (CExpr -> CExpr
mdataWeight CExpr
mE) ]
                        PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
forall (a :: Hakaru).
PrintConfig -> Sing a -> CExpr -> Maybe CExpr -> CodeGen ()
printCG PrintConfig
pconfig Sing a
typ (CExpr -> CExpr
mdataSample CExpr
mE) Maybe CExpr
forall a. Maybe a
Nothing
          CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG (CExpr
numSamples CExpr -> CExpr -> CExpr
.>=. (Integer -> CExpr
intE Integer
0))
               (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostDecOp CExpr
itE)
               (() -> CodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

printCG PrintConfig
pconfig (SArray typ) CExpr
arg Maybe CExpr
Nothing =
  do CExpr
itE <- Sing 'HNat -> String -> CodeGen CExpr
forall (a :: Hakaru). Sing a -> String -> CodeGen CExpr
localVar' Sing 'HNat
SNat String
"it"
     String -> CodeGen ()
putString String
"[ "
     CodeGen () -> CodeGen ()
forall a. CodeGen a -> CodeGen a
seqDo (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
       CExpr -> CExpr -> CExpr -> CodeGen () -> CodeGen ()
forCG (CExpr
itE CExpr -> CExpr -> CExpr
.=. (Integer -> CExpr
intE Integer
0))
             (CExpr
itE CExpr -> CExpr -> CExpr
.<. (CExpr -> CExpr
arraySize CExpr
arg))
             (CUnaryOp -> CExpr -> CExpr
CUnary CUnaryOp
CPostIncOp CExpr
itE)
             (CExpr -> CodeGen ()
putExprStat
             (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE [ String -> CExpr
stringE (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
pconfig Sing a
typ String
" "
                       , CExpr -> CExpr -> CExpr
index (CExpr -> CExpr
arrayData CExpr
arg) CExpr
itE ])
     String -> CodeGen ()
putString String
"]\n"
  where putString :: String -> CodeGen ()
putString String
s = CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE [String -> CExpr
stringE String
s]

-- bool and unit
printCG PrintConfig
_ (SData (STyCon sym)  _) CExpr
arg Maybe CExpr
Nothing =
  case Sing s -> String
forall (s :: Symbol). Sing s -> String
ssymbolVal Sing s
sym of
    String
"Unit" -> CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE [String -> CExpr
stringE String
"()\n"]
    String
"Bool" -> CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
ifCG (CExpr -> CExpr
datumIndex CExpr
arg CExpr -> CExpr -> CExpr
.==. (Integer -> CExpr
intE Integer
0))
                   (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE [String -> CExpr
stringE String
"true\n"])
                   (CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE [String -> CExpr
stringE String
"false\n"])
    String
_ -> String -> CodeGen ()
forall a. HasCallStack => String -> a
error (String -> CodeGen ()) -> String -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Sing s -> String
forall a. Show a => a -> String
show Sing s
sym

printCG PrintConfig
pconfig Sing a
SProb CExpr
arg Maybe CExpr
Nothing =
  CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE
                      [ String -> CExpr
stringE (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ PrintConfig -> Sing 'HProb -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
pconfig Sing 'HProb
SProb String
"\n"
                      , if PrintConfig -> Bool
showProbInLog PrintConfig
pconfig
                        then CExpr
arg
                        else CExpr -> CExpr
expE CExpr
arg ]

printCG PrintConfig
pconfig Sing a
typ CExpr
arg Maybe CExpr
Nothing =
  CExpr -> CodeGen ()
putExprStat (CExpr -> CodeGen ()) -> CExpr -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ [CExpr] -> CExpr
printfE
              [ String -> CExpr
stringE (String -> CExpr) -> String -> CExpr
forall a b. (a -> b) -> a -> b
$ PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
pconfig Sing a
typ String
"\n"
              , CExpr
arg ]

-- we should only have a number of samples if it a measure
printCG PrintConfig
_ Sing a
_ CExpr
_ (Just CExpr
_) = String -> CodeGen ()
forall a. HasCallStack => String -> a
error String
"this should not happen"


printFormat :: PrintConfig -> Sing (a :: Hakaru) -> (String -> String)
printFormat :: PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
_ Sing a
SInt         = \String
s -> String
"%d" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
printFormat PrintConfig
_ Sing a
SNat         = \String
s -> String
"%d" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
printFormat PrintConfig
c Sing a
SProb        = \String
s -> if PrintConfig -> Bool
showProbInLog PrintConfig
c
                                  then String
"exp(%.15f)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
                                  else String
"%.15f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
printFormat PrintConfig
_ Sing a
SReal        = \String
s -> String
"%.15f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
printFormat PrintConfig
c (SMeasure t) = if PrintConfig -> Bool
noWeights PrintConfig
c
                             then PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
c Sing a
t
                             else \String
s -> if PrintConfig -> Bool
showProbInLog PrintConfig
c
                                        then String
"exp(%.15f) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
c Sing a
t String
s
                                        else String
"%.15f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
c Sing a
t String
s
printFormat PrintConfig
c (SArray t)   = PrintConfig -> Sing a -> String -> String
forall (a :: Hakaru). PrintConfig -> Sing a -> String -> String
printFormat PrintConfig
c Sing a
t
printFormat PrintConfig
_ (SFun _ _)   = String -> String
forall a. a -> a
id
printFormat PrintConfig
_ (SData _ _)  = \String
s -> String
"TODO: printft datum" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s


--------------------------------------------------------------------------------
--                           Wrapping   Lambdas                               --
--------------------------------------------------------------------------------
{-

Lambdas become function in C. The Hakaru ABT only allows one arguement for each
lambda. So at the top level of a Hakaru program that is a function there may be
several nested lambdas. In C however, we can and should coalesce these into one
function with several arguements. This is what flattenTopLambda is for.

-}


flattenTopLambda
  :: ABT Term abt
  => abt '[] a
  -> Ident
  -> CodeGen ()
flattenTopLambda :: abt '[] a -> Ident -> CodeGen ()
flattenTopLambda abt '[] a
abt Ident
name =
    abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> CodeGen ())
-> CodeGen ()
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
coalesceLambda abt '[] a
abt ((forall (ys :: [Hakaru]) (b :: Hakaru).
  List1 Variable ys -> abt '[] b -> CodeGen ())
 -> CodeGen ())
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> CodeGen ())
-> CodeGen ()
forall a b. (a -> b) -> a -> b
$ \List1 Variable ys
vars abt '[] b
abt' ->
    let varMs :: [StateT CG Identity CDecl]
varMs = (forall (i :: Hakaru). Variable i -> [StateT CG Identity CDecl])
-> List1 Variable ys -> [StateT CG Identity CDecl]
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 i
v -> [Variable i -> Ident -> StateT CG Identity CDecl
forall (a :: Hakaru).
Variable a -> Ident -> StateT CG Identity CDecl
mkVarDecl Variable i
v (Ident -> StateT CG Identity CDecl)
-> StateT CG Identity Ident -> StateT CG Identity CDecl
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Variable i -> StateT CG Identity Ident
forall (a :: Hakaru).
String -> Variable a -> StateT CG Identity Ident
createIdent' String
"param" Variable i
v]) List1 Variable ys
vars
        typ :: Sing b
typ   = abt '[] b -> Sing b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt '[] b
abt'
    in  do [CDecl]
argDecls <- [StateT CG Identity CDecl] -> StateT CG Identity [CDecl]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [StateT CG Identity CDecl]
varMs
           [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
funCG (Sing b -> [CTypeSpec]
forall (a :: Hakaru). Sing a -> [CTypeSpec]
buildType Sing b
typ) Ident
name [CDecl]
argDecls (CodeGen () -> CodeGen ()) -> CodeGen () -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
             (CStat -> CodeGen ()
putStat (CStat -> CodeGen ()) -> (CExpr -> CStat) -> CExpr -> CodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> CStat
CReturn (Maybe CExpr -> CStat) -> (CExpr -> Maybe CExpr) -> CExpr -> CStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just) (CExpr -> CodeGen ()) -> CodeGen CExpr -> CodeGen ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< abt '[] b -> String -> CodeGen CExpr
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> String -> CodeGen CExpr
flattenWithName' abt '[] b
abt' String
"out"

  -- do at top level
  where mkVarDecl :: Variable (a :: Hakaru) -> Ident -> CodeGen CDecl
        mkVarDecl :: Variable a -> Ident -> StateT CG Identity CDecl
mkVarDecl (Variable Text
_ Nat
_ Sing a
SInt)  = CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> (Ident -> CDecl) -> Ident -> StateT CG Identity CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing 'HInt -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing 'HInt
SInt
        mkVarDecl (Variable Text
_ Nat
_ Sing a
SNat)  = CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> (Ident -> CDecl) -> Ident -> StateT CG Identity CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing 'HNat -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing 'HNat
SNat
        mkVarDecl (Variable Text
_ Nat
_ Sing a
SProb) = CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> (Ident -> CDecl) -> Ident -> StateT CG Identity CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing 'HProb -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing 'HProb
SProb
        mkVarDecl (Variable Text
_ Nat
_ Sing a
SReal) = CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> (Ident -> CDecl) -> Ident -> StateT CG Identity CDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing 'HReal -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
typeDeclaration Sing 'HReal
SReal
        mkVarDecl (Variable Text
_ Nat
_ (SArray t)) = \Ident
i ->
          Sing ('HArray a) -> CodeGen ()
forall (a :: Hakaru). Sing a -> CodeGen ()
extDeclareTypes (Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing a
t) CodeGen () -> StateT CG Identity CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> CDecl -> StateT CG Identity CDecl
forall a b. (a -> b) -> a -> b
$ Sing a -> Ident -> CDecl
forall (a :: Hakaru). Sing a -> Ident -> CDecl
arrayDeclaration Sing a
t Ident
i)

        mkVarDecl (Variable Text
_ Nat
_ d :: Sing a
d@(SData _ _)) = \Ident
i ->
          Sing a -> CodeGen ()
forall (a :: Hakaru). Sing a -> CodeGen ()
extDeclareTypes Sing a
d CodeGen () -> StateT CG Identity CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CDecl -> StateT CG Identity CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> StateT CG Identity CDecl)
-> CDecl -> StateT CG Identity CDecl
forall a b. (a -> b) -> a -> b
$ Sing (HData' t) -> Ident -> CDecl
forall (t :: HakaruCon). Sing (HData' t) -> Ident -> CDecl
datumDeclaration Sing a
Sing (HData' t)
d Ident
i)

        mkVarDecl Variable a
v = String -> Ident -> StateT CG Identity CDecl
forall a. HasCallStack => String -> a
error (String -> Ident -> StateT CG Identity CDecl)
-> String -> Ident -> StateT CG Identity CDecl
forall a b. (a -> b) -> a -> b
$ String
"flattenSCon.Lam_.mkVarDecl cannot handle vars of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Variable a -> String
forall a. Show a => a -> String
show Variable a
v

coalesceLambda
  :: ABT Term abt
  => abt '[] a
  -> ( forall (ys :: [Hakaru]) b
     . List1 Variable ys -> abt '[] b -> r)
  -> r
coalesceLambda :: abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
coalesceLambda abt '[] a
abt_ forall (ys :: [Hakaru]) (b :: Hakaru).
List1 Variable ys -> abt '[] b -> r
k =
  abt '[] a -> (Variable a -> r) -> (Term abt a -> r) -> r
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn abt '[] a
abt_ (r -> Variable a -> r
forall a b. a -> b -> a
const (List1 Variable '[] -> abt '[] a -> r
forall (ys :: [Hakaru]) (b :: Hakaru).
List1 Variable ys -> abt '[] b -> r
k List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1 abt '[] a
abt_)) ((Term abt a -> r) -> r) -> (Term abt a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Term abt a
term ->
    case Term abt a
term of
      (SCon args a
Lam_ :$ abt vars a
body :* SArgs abt args
End) ->
        abt '[a] a -> (Variable a -> abt '[] a -> r) -> r
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
body ((Variable a -> abt '[] a -> r) -> r)
-> (Variable a -> abt '[] a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Variable a
v abt '[] a
body' ->
           abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
abt '[] a
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
coalesceLambda abt '[] a
body' ((forall (ys :: [Hakaru]) (b :: Hakaru).
  List1 Variable ys -> abt '[] b -> r)
 -> r)
-> (forall (ys :: [Hakaru]) (b :: Hakaru).
    List1 Variable ys -> abt '[] b -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \List1 Variable ys
vars abt '[] b
body'' -> List1 Variable (a : ys) -> abt '[] b -> r
forall (ys :: [Hakaru]) (b :: Hakaru).
List1 Variable ys -> abt '[] b -> r
k (Variable a -> List1 Variable ys -> List1 Variable (a : ys)
forall a (a :: a -> *) (x :: a) (xs :: [a]).
a x -> List1 a xs -> List1 a (x : xs)
Cons1 Variable a
v List1 Variable ys
vars) abt '[] b
body''
      Term abt a
_ -> List1 Variable '[] -> abt '[] a -> r
forall (ys :: [Hakaru]) (b :: Hakaru).
List1 Variable ys -> abt '[] b -> r
k List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1 abt '[] a
abt_

foldLambdaWithIndex
  :: ABT Term abt
  => Integer
  -> abt '[] a
  -> ( forall (x :: Hakaru)
     .  Integer
     -> Variable x
     -> CodeGen CExpr)
  -> CodeGen [CExpr]
foldLambdaWithIndex :: Integer
-> abt '[] a
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
foldLambdaWithIndex Integer
n abt '[] a
abt_ forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr
k =
  abt '[] a
-> (Variable a -> CodeGen [CExpr])
-> (Term abt a -> CodeGen [CExpr])
-> CodeGen [CExpr]
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn abt '[] a
abt_
    (CodeGen [CExpr] -> Variable a -> CodeGen [CExpr]
forall a b. a -> b -> a
const ([CExpr] -> CodeGen [CExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return []))
    (\Term abt a
term ->
      case Term abt a
term of
        (SCon args a
Lam_ :$ abt vars a
body :* SArgs abt args
End) ->
          abt '[a] a
-> (Variable a -> abt '[] a -> CodeGen [CExpr]) -> CodeGen [CExpr]
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
body ((Variable a -> abt '[] a -> CodeGen [CExpr]) -> CodeGen [CExpr])
-> (Variable a -> abt '[] a -> CodeGen [CExpr]) -> CodeGen [CExpr]
forall a b. (a -> b) -> a -> b
$ \Variable a
v abt '[] a
abt_' ->
            (do CExpr
x <- Integer -> Variable a -> CodeGen CExpr
forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr
k Integer
n Variable a
v
                [CExpr]
xs <- Integer
-> abt '[] a
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Integer
-> abt '[] a
-> (forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr)
-> CodeGen [CExpr]
foldLambdaWithIndex (Integer -> Integer
forall a. Enum a => a -> a
succ Integer
n) abt '[] a
abt_' forall (x :: Hakaru). Integer -> Variable x -> CodeGen CExpr
k
                [CExpr] -> CodeGen [CExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr
xCExpr -> [CExpr] -> [CExpr]
forall a. a -> [a] -> [a]
:[CExpr]
xs))
        Term abt a
_ -> [CExpr] -> CodeGen [CExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [])