hakaru 0.1.4 → 0.3.0

raw patch · 82 files changed

+26228/−1427 lines, 82 filesdep +ansi-terminaldep +filepathdep +indentation-parsecdep −aesondep −arraydep −bytestringdep ~Cabaldep ~HUnitdep ~QuickChecknew-component:exe:compilenew-component:exe:densitynew-component:exe:disintegratenew-component:exe:hakarunew-component:exe:hkcnew-component:exe:mhnew-component:exe:momijinew-component:exe:normalizenew-component:exe:prettynew-component:exe:simplifyPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, filepath, indentation-parsec, mtl, optparse-applicative, process, semigroups

Dependencies removed: aeson, array, bytestring, cassava, criterion, deepseq, hmatrix, monad-loops, parallel, random, statistics, test-framework, test-framework-hunit, test-framework-quickcheck2, zlib

Dependency ranges changed: Cabal, HUnit, QuickCheck, base, ghc-prim, hakaru, integration, logfloat, math-functions, primitive, text, transformers, vector

API changes (from Hackage documentation)

Files

• Bench/Bench.hs +0/−20
• LICENSE +1/−1
• Language/Hakaru/Arrow.hs +0/−6
• Language/Hakaru/Distribution.hs +0/−232
• Language/Hakaru/ImportanceSampler.hs +0/−94
• Language/Hakaru/Lambda.hs +0/−22
• Language/Hakaru/Metropolis.hs +0/−212
• Language/Hakaru/Mixture.hs +0/−61
• Language/Hakaru/Sampler.hs +0/−28
• Language/Hakaru/Symbolic.hs +0/−185
• Language/Hakaru/Types.hs +0/−31
• Language/Hakaru/Util/Coda.hs +0/−20
• Language/Hakaru/Util/Csv.hs +0/−40
• Language/Hakaru/Util/Extras.hs +0/−79
• Language/Hakaru/Util/Visual.hs +0/−43
• Tests/Distribution.hs +0/−51
• Tests/ImportanceSampler.hs +0/−119
• Tests/Metropolis.hs +0/−45
• Tests/Models.hs +0/−26
• Tests/Tests.hs +0/−24
• commands/Compile.hs +122/−0
• commands/Density.hs +38/−0
• commands/Disintegrate.hs +40/−0
• commands/HKC.hs +132/−0
• commands/Hakaru.hs +93/−0
• commands/Mh.hs +38/−0
• commands/Momiji.hs +32/−0
• commands/Normalize.hs +37/−0
• commands/Pretty.hs +29/−0
• commands/Simplify.hs +55/−0
• hakaru.cabal +270/−88
• haskell/Data/Number/Nat.hs +165/−0
• haskell/Data/Number/Natural.hs +210/−0
• haskell/Language/Hakaru/CodeGen/AST.hs +388/−0
• haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs +364/−0
• haskell/Language/Hakaru/CodeGen/Flatten.hs +1244/−0
• haskell/Language/Hakaru/CodeGen/Pretty.hs +295/−0
• haskell/Language/Hakaru/CodeGen/Types.hs +349/−0
• haskell/Language/Hakaru/CodeGen/Wrapper.hs +349/−0
• haskell/Language/Hakaru/Command.hs +34/−0
• haskell/Language/Hakaru/Disintegrate.hs +1830/−0
• haskell/Language/Hakaru/Evaluation/Coalesce.hs +73/−0
• haskell/Language/Hakaru/Evaluation/ConstantPropagation.hs +68/−0
• haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs +910/−0
• haskell/Language/Hakaru/Evaluation/EvalMonad.hs +339/−0
• haskell/Language/Hakaru/Evaluation/ExpectMonad.hs +213/−0
• haskell/Language/Hakaru/Evaluation/Lazy.hs +814/−0
• haskell/Language/Hakaru/Evaluation/PEvalMonad.hs +662/−0
• haskell/Language/Hakaru/Evaluation/Types.hs +915/−0
• haskell/Language/Hakaru/Expect.hs +385/−0
• haskell/Language/Hakaru/Inference.hs +217/−0
• haskell/Language/Hakaru/Observe.hs +96/−0
• haskell/Language/Hakaru/Parser/AST.hs +448/−0
• haskell/Language/Hakaru/Parser/Maple.hs +598/−0
• haskell/Language/Hakaru/Parser/Parser.hs +539/−0
• haskell/Language/Hakaru/Parser/SymbolResolve.hs +586/−0
• haskell/Language/Hakaru/Pretty/Concrete.hs +703/−0
• haskell/Language/Hakaru/Pretty/Haskell.hs +523/−0
• haskell/Language/Hakaru/Pretty/Maple.hs +382/−0
• haskell/Language/Hakaru/Runtime/Prelude.hs +229/−0
• haskell/Language/Hakaru/Sample.hs +598/−0
• haskell/Language/Hakaru/Simplify.hs +108/−0
• haskell/Language/Hakaru/Syntax/ABT.hs +1046/−0
• haskell/Language/Hakaru/Syntax/AST.hs +938/−0
• haskell/Language/Hakaru/Syntax/AST/Eq.hs +494/−0
• haskell/Language/Hakaru/Syntax/AST/Sing.hs +134/−0
• haskell/Language/Hakaru/Syntax/AST/Transforms.hs +89/−0
• haskell/Language/Hakaru/Syntax/Datum.hs +797/−0
• haskell/Language/Hakaru/Syntax/DatumABT.hs +51/−0
• haskell/Language/Hakaru/Syntax/DatumCase.hs +378/−0
• haskell/Language/Hakaru/Syntax/IClasses.hs +821/−0
• haskell/Language/Hakaru/Syntax/Prelude.hs +1634/−0
• haskell/Language/Hakaru/Syntax/TypeCheck.hs +1670/−0
• haskell/Language/Hakaru/Syntax/TypeOf.hs +195/−0
• haskell/Language/Hakaru/Syntax/Value.hs +106/−0
• haskell/Language/Hakaru/Syntax/Variable.hs +561/−0
• haskell/Language/Hakaru/Types/Coercion.hs +500/−0
• haskell/Language/Hakaru/Types/DataKind.hs +176/−0
• haskell/Language/Hakaru/Types/HClasses.hs +606/−0
• haskell/Language/Hakaru/Types/Sing.hs +418/−0
• haskell/System/MapleSSH.hs +53/−0
• haskell/Tests/TestSuite.hs +40/−0

@@ -1,20 +0,0 @@-import Criterion.Main--import Control.Monad--import Language.Hakaru.Distribution-import qualified Language.Hakaru.Metropolis as MH-import qualified Language.Hakaru.ImportanceSampler as IS--giveLast :: IO [(a,b)] -> IO (a,b)-giveLast samples = do s <- samples-                      return $ last (take 100 s)--main = defaultMain [-   bcompare [-     bench "is normal 10"  $ whnfIO $ giveLast (IS.sample (replicateM 10 (IS.unconditioned (normal 0 10))) [])-   , bench "is normal 20"  $ whnfIO $ giveLast (IS.sample (replicateM 20 (IS.unconditioned (normal 0 10))) [])-   , bench "mh normal 10"  $ whnfIO $ giveLast (MH.sample (replicateM 10 (MH.unconditioned (normal 0 10))) [])-   , bench "mh normal 20"  $ whnfIO $ giveLast (MH.sample (replicateM 20 (MH.unconditioned (normal 0 10))) [])-   ]- ]

@@ -1,4 +1,4 @@-Copyright (c) 2014, The Hakaru Team+Copyright (c) 2016, The Hakaru Team  All rights reserved. 

@@ -1,6 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Language.Hakaru.Arrow where--import Language.Hakaru.Types (Dist)--type a ~~> b = a -> Dist b

@@ -1,232 +0,0 @@-{-# LANGUAGE RankNTypes, BangPatterns, GADTs #-}-{-# OPTIONS -Wall #-}--module Language.Hakaru.Distribution where--import Control.Monad-import Control.Monad.Primitive-import Control.Monad.Loops-import qualified System.Random.MWC as MWC-import Language.Hakaru.Mixture-import Language.Hakaru.Types-import Data.Ix-import Data.Maybe (fromMaybe)-import Data.List (findIndex, foldl')-import Numeric.SpecFunctions-import qualified Data.Map.Strict as M-import qualified Data.Number.LogFloat as LF--mapFst :: (t -> s) -> (t, u) -> (s, u)-mapFst f (a,b) = (f a, b)--dirac :: (Eq a) => a -> Dist a-dirac theta = Dist {logDensity = (\ (Discrete x) -> if x == theta then 0 else log 0),-                    distSample = (\ _ -> return $ Discrete theta)}--bern :: Double -> Dist Bool-bern p = Dist {logDensity = (\ (Discrete x) -> log (if x then p else 1 - p)),-               distSample = (\ g -> do t <- MWC.uniformR (0,1) g-                                       return $ Discrete (t <= p))}--uniform :: Double -> Double -> Dist Double-uniform lo hi =-    let uniformLogDensity lo' hi' x | lo' <= x && x <= hi' = log (recip (hi' - lo'))-        uniformLogDensity _ _ _ = log 0-    in Dist {logDensity = (\ (Lebesgue x) -> uniformLogDensity lo hi x),-             distSample = (\ g -> liftM Lebesgue $ MWC.uniformR (lo, hi) g)}--uniformD :: (Ix a, MWC.Variate a) => a -> a -> Dist a-uniformD lo hi =-    let uniformLogDensity lo' hi' x | lo' <= x && x <= hi' = log density-        uniformLogDensity _ _ _ = log 0-        density = recip (fromInteger (toInteger (rangeSize (lo,hi))))-    in Dist {logDensity = (\ (Discrete x) -> uniformLogDensity lo hi x),-             distSample = (\ g -> liftM Discrete $ MWC.uniformR (lo, hi) g)}--marsaglia :: (MWC.Variate a, Ord a, Floating a, PrimMonad m) => PRNG m -> m (a, a)-marsaglia g = do -- "Marsaglia polar method"-  x <- MWC.uniformR (-1,1) g-  y <- MWC.uniformR (-1,1) g-  let s = x * x + y * y-      q = sqrt ((-2) * log s / s)-  if 1 >= s && s > 0 then return (x * q, y * q) else marsaglia g--choose :: (PrimMonad m) => Mixture k -> PRNG m -> m (k, Prob)-choose (Mixture m) g = do-  let peak = maximum (M.elems m)-      unMix = M.map (LF.fromLogFloat . (/peak)) m-      total = M.foldl' (+) (0::Double) unMix-  p <- MWC.uniformR (0, total) g-  let f !k !v b !p0 = let p1 = p0 + v in if p <= p1 then k else b p1-      err p0 = error ("choose: failure p0=" ++ show p0 ++-                      " total=" ++ show total ++-                      " size=" ++ show (M.size m))-  return $ (M.foldrWithKey f err unMix 0, LF.logFloat total * peak)--chooseIndex :: (PrimMonad m) => [Double] -> PRNG m -> m Int-chooseIndex probs g = do-  p <- MWC.uniform g-  return $ fromMaybe (error ("chooseIndex: failure p=" ++ show p))-           (findIndex (p <=) (scanl1 (+) probs))--normal_rng :: (Real a, Floating a, MWC.Variate a, PrimMonad m) =>-              a -> a -> PRNG m -> m a-normal_rng mu sd g | sd > 0 = do (x, _) <- marsaglia g-                                 return (mu + sd * x)-normal_rng _ _ _ = error "normal: invalid parameters"--normalLogDensity :: Floating a => a -> a -> a -> a-normalLogDensity mu sd x = (-tau * square (x - mu)-                            + log (tau / pi / 2)) / 2-  where square y = y * y-        tau = 1 / square sd--normal :: Double -> Double -> Dist Double -normal mu sd = Dist {logDensity = normalLogDensity mu sd . fromLebesgue,-                     distSample = (\g -> liftM Lebesgue $ normal_rng mu sd g)}--categoricalLogDensity :: (Eq b, Floating a) => [(b, a)] -> b -> a-categoricalLogDensity list x = log $ fromMaybe 0 (lookup x list)--categoricalSample :: (Num b, Ord b, PrimMonad m, MWC.Variate b) =>-    [(t,b)] -> PRNG m -> m t-categoricalSample list g = do-  let total = sum $ map snd list-  p <- MWC.uniformR (0, total) g-  let sumList = scanl1 (\acc (a, b) -> (a, b + snd(acc))) list-      elem' = fst $ head $ filter (\(_,p0) -> p <= p0) sumList-  return elem'--categorical :: Eq a => [(a,Double)] -> Dist a-categorical list = Dist {logDensity = categoricalLogDensity list . fromDiscrete,-                         distSample = (\g -> liftM Discrete $ categoricalSample list g)}--lnFact :: Int -> Double-lnFact = logFactorial---- Makes use of Atkinson's algorithm as described in:--- Monte Carlo Statistical Methods pg. 55------ Further discussion at:--- http://www.johndcook.com/blog/2010/06/14/generating-poisson-random-values/-poisson_rng :: (PrimMonad m) => Double -> PRNG m -> m Int-poisson_rng lambda g' = make_poisson g'-   where smu = sqrt lambda-         b  = 0.931 + 2.53*smu-         a  = -0.059 + 0.02483*b-         vr = 0.9277 - 3.6224/(b - 2)-         arep  = 1.1239 + 1.1368/(b-3.4)-         lnlam = log lambda--         make_poisson :: (PrimMonad m) => PRNG m -> m Int-         make_poisson g = do u <- MWC.uniformR (-0.5,0.5) g-                             v <- MWC.uniformR (0,1) g-                             let us = 0.5 - abs u-                                 k = floor $ (2*a / us + b)*u + lambda + 0.43-                             case () of-                               () | us >= 0.07 && v <= vr -> return k-                               () | k < 0 -> make_poisson g-                               () | us <= 0.013 && v > us -> make_poisson g-                               () | accept_region us v k -> return k-                               _  -> make_poisson g--         accept_region :: Double -> Double -> Int -> Bool-         accept_region us v k = log (v * arep / (a/(us*us)+b)) <=-                                -lambda + (fromIntegral k)*lnlam - lnFact k--poisson :: Double -> Dist Int-poisson l =-    let poissonLogDensity l' x | l' > 0 && x> 0 = (fromIntegral x)*(log l') - lnFact x - l'-        poissonLogDensity l' x | x==0 = -l'-        poissonLogDensity _ _ = log 0-    in Dist {logDensity = poissonLogDensity l . fromDiscrete,-             distSample = (\g -> liftM Discrete $ poisson_rng l g)}---- Direct implementation of  "A Simple Method for Generating Gamma Variables"--- by George Marsaglia and Wai Wan Tsang.-gamma_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double-gamma_rng shape _   _ | shape <= 0.0  = error "gamma: got a negative shape paramater"-gamma_rng _     scl _ | scl <= 0.0  = error "gamma: got a negative scale paramater"-gamma_rng shape scl g | shape <  1.0  = do gvar1 <- gamma_rng (shape + 1) scl g-                                           w <- MWC.uniformR (0,1) g-                                           return $ scl * gvar1 * (w ** recip shape)-gamma_rng shape scl g = do-    let d = shape - 1/3-        c = recip $ sqrt $ 9*d-        -- Algorithm recommends inlining normal generator-        -- n = normal_rng 1 c-    v <- iterateUntil (> 0.0) $ normal_rng 1 c g-        -- (v, g2) = until (\y -> fst y > 0.0) (\ (_, g') -> normal_rng 1 c g') (n g)-    let x = (v - 1) / c-        sqr = x * x-        v3 = v * v * v-    u <- MWC.uniformR (0.0, 1.0) g-    let accept = u < 1.0 - 0.0331*(sqr*sqr) || log u < 0.5*sqr + d*(1.0 - v3 + log v3)-    case accept of-      True -> return $ scl*d*v3-      False -> gamma_rng shape scl g--gammaLogDensity :: Double -> Double -> Double -> Double-gammaLogDensity shape scl x | x>= 0 && shape > 0 && scl > 0 =-     scl * log shape - scl * x + (shape - 1) * log x - logGamma shape-gammaLogDensity _ _ _ = log 0--gamma :: Double -> Double -> Dist Double-gamma shape scl = Dist {logDensity = gammaLogDensity shape scl . fromLebesgue,-                        distSample = (\g -> liftM Lebesgue $ gamma_rng shape scl g)}--beta_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double-beta_rng a b g | a <= 1.0 && b <= 1.0 = do-                 u <- MWC.uniformR (0.0, 1.0) g-                 v <- MWC.uniformR (0.0, 1.0) g-                 let x = u ** (recip a)-                     y = v ** (recip b)-                 case (x+y) <= 1.0 of-                   True -> return $ x / (x + y)-                   False -> beta_rng a b g-beta_rng a b g = do ga <- gamma_rng a 1 g-                    gb <- gamma_rng b 1 g-                    return $ ga / (ga + gb)--betaLogDensity :: Double -> Double -> Double -> Double-betaLogDensity _ _ x | x < 0 || x > 1 = error "beta: value must be between 0 and 1"-betaLogDensity a b _ | a <= 0 || b <= 0 = error "beta: parameters must be positve" -betaLogDensity a b x = (logGamma (a + b)-                        - logGamma a-                        - logGamma b-                        + (a - 1) * log x-                        + (b - 1) * log (1 - x))--beta :: Double -> Double -> Dist Double-beta a b = Dist {logDensity = betaLogDensity a b . fromLebesgue,-                 distSample = (\g -> liftM Lebesgue $ beta_rng a b g)}--laplace_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double-laplace_rng mu sd g = MWC.uniformR (0.0, 1.0) g >>= sample-   where sample u = return $ case u < 0.5 of-                               True  -> mu + sd * log (u + u)-                               False -> mu - sd * log (2.0 - u - u)--laplaceLogDensity :: Floating a => a -> a -> a -> a-laplaceLogDensity mu sd x = - log (2 * sd) - abs (x - mu) / sd--laplace :: Double -> Double -> Dist Double-laplace mu sd = Dist {logDensity = laplaceLogDensity mu sd . fromLebesgue,-                      distSample = (\g -> liftM Lebesgue $ laplace_rng mu sd g)}---- Consider having dirichlet return Vector--- Note: This is actually symmetric dirichlet-dirichlet_rng :: (PrimMonad m) => Int ->  Double -> PRNG m -> m [Double]-dirichlet_rng n' a g' = liftM normalize $ gammas g' n'-  where gammas _ 0 = return ([], 0)-        gammas g n = do (xs, total) <- gammas g (n-1)-                        x <- gamma_rng a 1 g-                        return ((x : xs), x+total)-        normalize (b, total) = map (/ total) b--dirichletLogDensity :: [Double] -> [Double] -> Double-dirichletLogDensity a x | all (> 0) x = sum' (zipWith logTerm a x) + logGamma (sum a)-  where sum' = foldl' (+) 0-        logTerm b y = (b-1) * log y - logGamma b-dirichletLogDensity _ _ = error "dirichlet: all values must be between 0 and 1"-

@@ -1,94 +0,0 @@-{-# LANGUAGE RankNTypes, NoMonomorphismRestriction, BangPatterns #-}-{-# OPTIONS -W #-}--module Language.Hakaru.ImportanceSampler where---- This is an interpreter that's like Interpreter except conditioning is--- checked at run time rather than by static types.  In other words, we allow--- models to be compiled whose conditioned parts do not match the observation--- inputs.  In exchange, we get to make Measure an instance of Monad, and we--- can express models whose number of observations is unknown at compile time.--import Language.Hakaru.Types-import Language.Hakaru.Mixture (Prob, empty, point, Mixture(..))-import Language.Hakaru.Sampler (Sampler, deterministic, smap, sbind)--import qualified System.Random.MWC as MWC-import Control.Monad.Primitive-import Data.Monoid-import Data.Dynamic-import System.IO.Unsafe-import qualified Data.Map.Strict as M--import qualified Data.Number.LogFloat as LF---- Conditioned sampling-newtype Measure a = Measure { unMeasure :: [Cond] -> Sampler (a, [Cond]) }--bind :: Measure a -> (a -> Measure b) -> Measure b-bind measure continuation =-  Measure (\conds ->-    sbind (unMeasure measure conds)-          (\(a,cds) -> unMeasure (continuation a) cds))--instance Monad Measure where-  return x = Measure (\conds -> deterministic (point (x,conds) 1))-  (>>=)    = bind--updateMixture :: Typeable a => Cond -> Dist a -> Sampler a-updateMixture (Just cond) dist =-    case fromDynamic cond of-      Just y  -> deterministic (point (fromDensity y) density)-          where density = LF.logToLogFloat $ logDensity dist y-      Nothing -> error "did not get data from dynamic source"-updateMixture Nothing     dist = \g -> do e <- distSample dist g-                                          return $ point (fromDensity e) 1-    -conditioned, unconditioned :: Typeable a => Dist a -> Measure a-conditioned   dist = Measure (\(cond:conds) -> smap (\a->(a,conds))-                                               (updateMixture cond    dist))-unconditioned dist = Measure (\      conds  -> smap (\a->(a,conds))-                                               (updateMixture Nothing dist))--factor :: Prob -> Measure ()-factor p = Measure (\conds -> deterministic (point ((), conds) p))--condition :: Eq b => Measure (a, b) -> b -> Measure a-condition m b' =-    Measure (\ conds -> -      sbind (unMeasure m conds)-            (\ ((a,b), cds) ->-                 deterministic (if b==b' then point (a,cds) 1 else empty)))---- Drivers for testing-finish :: Mixture (a, [Cond]) -> Mixture a-finish (Mixture m) = Mixture (M.mapKeysMonotonic (\(a,[]) -> a) m)--empiricalMeasure :: (PrimMonad m, Ord a) => Int -> Measure a -> [Cond] -> m (Mixture a)-empiricalMeasure !n measure conds = do-  gen <- MWC.create-  go n gen empty-    where once = unMeasure measure conds-          go 0 _ m = return m-          go k g m = once g >>= \result -> go (k - 1) g $! mappend m (finish result)--sample :: Measure a -> [Cond] -> IO [(a, Prob)]-sample measure conds = do-  gen <- MWC.create-  unsafeInterleaveIO $ sampleNext gen-      where once = unMeasure measure conds-            mixToTuple = head . M.toList . unMixture-            sampleNext g = do-              u <- once g-              let x = mixToTuple (finish u)-              xs <- unsafeInterleaveIO $ sampleNext g-              return (x : xs)- --  u <- once gen- --  let x = mixToTuple (finish u)- --  xs <- unsafeInterleaveIO $ sample measure conds gen- --  return (x : xs)- -- where once = unMeasure measure conds- --       mixToTuple = head . M.toList . unMixture--logit :: Floating a => a -> a-logit !x = 1 / (1 + exp (- x))

@@ -1,22 +0,0 @@--- The lambda-calculus part of the language, which can be shared-module Language.Hakaru.Lambda(lit, dbl, lam, app, fix, ifThenElse) where--lit :: (Eq a) => a -> a-lit = id---- raw lit is a pain to use.  These are nicer-dbl :: Double -> Double-dbl = lit--lam :: (a -> b) -> (a -> b)-lam f = f--app :: (a -> b) -> a -> b-app f x = f x--fix :: ((a -> b) -> (a -> b)) -> (a -> b)-fix g = f where f = g f--ifThenElse :: Bool -> a -> a -> a-ifThenElse True  t _ = t-ifThenElse False _ f = f

@@ -1,212 +0,0 @@-{-# LANGUAGE RankNTypes, NoMonomorphismRestriction, BangPatterns,-  DeriveDataTypeable, GADTs, ScopedTypeVariables,-  ExistentialQuantification, StandaloneDeriving #-}-{-# OPTIONS -Wall #-}--module Language.Hakaru.Metropolis where--import qualified System.Random.MWC as MWC-import Control.Monad-import Control.Monad.Primitive-import Data.Dynamic-import Data.Maybe-import Control.Applicative--import qualified Data.Map.Strict as M-import Language.Hakaru.Types--import System.IO.Unsafe--{---Shortcomings of this implementation--* uses parent-conditional sampling for proposal distribution-* re-evaluates entire program at every sample-* lacks way to block sample groups of variables---}--type DistVal = Dynamic- -data XRP where-  XRP :: Typeable e => (Density e, Dist e) -> XRP--unXRP :: Typeable a => XRP -> Maybe (Density a, Dist a)-unXRP (XRP (e,f)) = cast (e,f)--type Visited = Bool-type Observed = Bool-type LL = LogLikelihood---- The first component is the LogLikelihood of the trace--- The second is the LogLikelihood of the newly introduced--- choices. These are used to compute the acceptance ratio-type LL2 = (LL,LL)--type Subloc = Int-type Name = [Subloc]-data DBEntry = DBEntry {-      xrp  :: XRP, -      llhd :: LL, -      vis  :: Visited,-      observed :: Observed }-type Database = M.Map Name DBEntry--data SamplerState where-  S :: { ldb :: Database, -- ldb = local database-         -- (total likelihood, total likelihood of XRPs newly introduced)-         llh2 :: {-# UNPACK #-} !LL2,-         cnds :: [Cond] -- conditions left to process-       } -> SamplerState--type Sampler a = PrimMonad m => SamplerState -> PRNG m -> m (a, SamplerState)--sreturn :: a -> Sampler a-sreturn x s _ = return (x, s)--sbind :: Sampler a -> (a -> Sampler b) -> Sampler b-sbind s k = \ st g -> do (v, s') <- s st g-                         k v s' g--smap :: (a -> b) -> Sampler a -> Sampler b-smap f s = sbind s (\a -> sreturn (f a))--newtype Measure a = Measure {unMeasure :: Name -> Sampler a }-  deriving (Typeable)--return_ :: a -> Measure a-return_ x = Measure $ \ _ -> sreturn x--updateXRP :: Typeable a => Name -> Cond -> Dist a -> Sampler a-updateXRP n obs dist' s@(S {ldb = db}) g = do-    case M.lookup n db of-      Just (DBEntry xd _ _ ob) ->-          do let Just (x, _) = unXRP xd-                 l' = logDensity dist' x-                 d1 = M.insert n (DBEntry (XRP (x,dist')) l' True ob) db-             return (fromDensity x,-                     s {ldb = d1,-                        llh2 = updateLogLikelihood (l',0) (llh2 s)})-      Nothing ->-          do (xnew2, l) <- case obs of-                             Just xdnew ->-                                 do let Just xnew = fromDynamic xdnew-                                    return $ (xnew, logDensity dist' xnew)-                             Nothing ->-                                 do xnew <- distSample dist' g-                                    return (xnew, logDensity dist' xnew)-             let d1 = M.insert n (DBEntry (XRP (xnew2, dist')) l True (isJust obs)) db-             return (fromDensity xnew2,-                     s {ldb = d1,-                        llh2 = updateLogLikelihood (l,l) (llh2 s)})--updateLogLikelihood :: LL2 -> LL2 -> LL2-updateLogLikelihood (llTotal,llFresh) (l,lf) = (llTotal+l, llFresh+lf)--factor :: LL -> Measure ()-factor l = Measure $ \ _ -> \ s _ ->-   do let (llTotal, llFresh) = llh2 s-      return ((), s {llh2 = (llTotal + l, llFresh)})--condition :: Eq b => Measure (a, b) -> b -> Measure a-condition (Measure m) b' = Measure $ \ n ->-    do let comp a b s |  a /= b = s {llh2 = (log 0, 0)}-           comp _ _ s =  s-       sbind (m n) (\ (a, b) s _ -> return (a, comp b b' s))--bind :: Measure a -> (a -> Measure b) -> Measure b-bind (Measure m) cont = Measure $ \ n ->-    sbind (m (0:n)) (\ a -> unMeasure (cont a) (1:n))--conditioned :: Typeable a => Dist a -> Measure a-conditioned dist = Measure $ \ n -> -    \s@(S {cnds = cond:conds }) ->-        updateXRP n cond dist s{cnds = conds}--unconditioned :: Typeable a => Dist a -> Measure a-unconditioned dist = Measure $ \ n ->-    updateXRP n Nothing dist--instance Monad Measure where-  return = return_-  (>>=)  = bind--instance Functor Measure where-  fmap f (Measure x) = Measure $ \n -> smap f (x n)--instance Applicative Measure where-  pure = return_-  (<*>) = app--sapp :: (Sampler (a -> b)) -> Sampler a -> Sampler b-sapp f s = \st g -> do (vf, s')  <- f st g-                       (vs, s'') <- s s' g-                       sreturn (vf vs) s'' g--app :: Measure (a -> b) -> Measure a -> Measure b-app (Measure f) (Measure a) = Measure $ \n -> sapp (f n) (a n)--run :: Measure a -> [Cond] -> IO (a, Database, LL)-run (Measure prog) cds = do-  g <- MWC.create-  (v, S d ll []) <- (prog [0]) (S M.empty (0,0) cds) g-  return (v, d, fst ll)--traceUpdate :: PrimMonad m => Measure a -> Database -> [Cond] -> PRNG m-            -> m (a, Database, LL, LL, LL)-traceUpdate (Measure prog) d cds g = do-  -- let d1 = M.map (\ (x, l, _, ob) -> (x, l, False, ob)) d-  let d1 = M.map (\ s -> s { vis = False }) d-  (v, S d2 (llTotal, llFresh) []) <- (prog [0]) (S d1 (0,0) cds) g-  let (d3, stale_d) = M.partition vis d2-  let llStale = M.foldl' (\ llStale' s -> llStale' + llhd s) 0 stale_d-  return (v, d3, llTotal, llFresh, llStale)--initialStep :: Measure a -> [Cond] ->-               PRNG IO -> IO (a, Database, LL, LL, LL)-initialStep prog cds g = traceUpdate prog M.empty cds g---- TODO: Make a way of passing user-provided proposal distributions-resample :: PrimMonad m => Name -> Database -> Observed -> XRP -> PRNG m ->-            m (Database, LL, LL, LL)-resample name db ob (XRP (x, dist)) g =-    do x' <- distSample dist g-       let fwd = logDensity dist x'-           rvs = logDensity dist x-           l' = fwd-           newEntry = DBEntry (XRP (x', dist)) l' True ob-           db' = M.insert name newEntry db-       return (db', l', fwd, rvs)--transition :: (Typeable a) => Measure a -> [Cond]-           -> a -> Database -> LL -> PRNG IO -> IO [a]-transition prog cds v db ll g =-  do let dbSize = M.size db-         -- choose an unconditioned choice-         (_, uncondDb) = M.partition observed db-     choice <- MWC.uniformR (0, (M.size uncondDb) -1) g-     let (name, (DBEntry xd _ _ ob))  = M.elemAt choice uncondDb-     (db', _, fwd, rvs) <- resample name db ob xd g-     (v', db2, llTotal, llFresh, llStale) <- traceUpdate prog db' cds g-     let a = llTotal - ll-             + rvs - fwd-             + log (fromIntegral dbSize) - log (fromIntegral $ M.size db2)-             + llStale - llFresh-     u <- MWC.uniformR (0 :: Double, 1) g-     if (log u < a) then-         liftM ((:) v') $ unsafeInterleaveIO (transition prog cds v' db2 llTotal g)-     else-         liftM ((:) v) $ unsafeInterleaveIO (transition prog cds v db ll g)--mcmc :: Typeable a => Measure a -> [Cond] -> IO [a]-mcmc prog cds = do-  g <- MWC.create-  (v, d, llTotal, _, _) <- initialStep prog cds g-  transition prog cds v d llTotal g--sample :: Typeable a => Measure a -> [Cond] -> IO [(a, Double)]-sample prog cds  = do -  g <- MWC.create-  (v, d, llTotal, _, _) <- initialStep prog cds g-  (transition prog cds v d llTotal g) >>= return . map (\ x -> (x,1)) 

@@ -1,61 +0,0 @@-{-# LANGUAGE RankNTypes, BangPatterns #-}-{-# OPTIONS -W #-}--module Language.Hakaru.Mixture (Prob, point, empty, scale,-  Mixture(..), toList, mnull, mmap, cross, mode) where--import Data.Monoid-import Data.Ord (comparing)-import Data.List (maximumBy)-import qualified Data.Map.Strict as M-import Data.Number.LogFloat hiding (isInfinite)-import Text.Show (showListWith)-import Numeric (showFFloat)--type Prob = LogFloat---- Mixtures (the results of importance sampling)--newtype Mixture k = Mixture { unMixture :: M.Map k Prob }--instance (Show k) => Show (Mixture k) where-  showsPrec d (Mixture m) = showParen (d > 0) $-    showString "Mixture $ fromList " . showListWith s (M.toList m)-    where s (k,p) = showChar '('-                  . shows k-                  . showChar ','-                  . (if isInfinite l || -42 < l && l < 42-                     then showFFloat Nothing (fromLogFloat p :: Double)-                     else showString "logToLogFloat " . showsPrec 11 l)-                  . showChar ')'-            where l = logFromLogFloat p :: Double--instance (Ord k) => Monoid (Mixture k) where-  mempty        = empty-  mappend m1 m2 = Mixture (M.unionWith (+) (unMixture m1) (unMixture m2))-  mconcat ms    = Mixture (M.unionsWith (+) (map unMixture ms))--empty :: Mixture k-empty = Mixture M.empty--toList :: Mixture k -> [(k, Prob)]-toList = M.toList . unMixture--mnull :: Mixture k -> Bool-mnull = all (0>=) . M.elems . unMixture--point :: k -> Prob -> Mixture k-point k !v = Mixture (M.singleton k v)--scale :: Prob -> Mixture k -> Mixture k-scale !v = Mixture . M.map (v *) . unMixture--mmap :: (Ord k2) => (k1 -> k2) -> Mixture k1 -> Mixture k2-mmap f = Mixture . M.mapKeysWith (+) f . unMixture--cross :: (Ord k) => (k1 -> k2 -> k) -> Mixture k1 -> Mixture k2 -> Mixture k-cross f m1 m2 = mconcat [ mmap (`f` k) (scale v m1)-                        | (k,v) <- M.toList (unMixture m2) ]--mode :: Mixture k -> (k, Prob)-mode (Mixture m) = maximumBy (comparing snd) (M.toList m)

@@ -1,28 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS -W #-}--module Language.Hakaru.Sampler (Sampler, deterministic, sbind, smap) where--import Language.Hakaru.Mixture (Mixture, mnull, empty, scale, point)-import Language.Hakaru.Distribution (choose)-import Language.Hakaru.Types-import Control.Monad.Primitive---- Sampling procedures that produce one sample--type Sampler a = PrimMonad m => PRNG m -> m (Mixture a)--deterministic :: Mixture a -> Sampler a-deterministic m _ = return m--sbind :: Sampler a -> (a -> Sampler b) -> Sampler b-sbind s k g = do-  m1 <- s g-  if mnull m1 then -      return empty-  else do (a, v) <- choose m1 g-          m2 <- k a g-          return (scale v m2)--smap :: (a -> b) -> Sampler a -> Sampler b-smap f s = sbind s (\a -> deterministic (point (f a) 1))

@@ -1,185 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}-{-# OPTIONS -Wall #-}--module Language.Hakaru.Symbolic where--import Prelude hiding (Real)--data Real-data Prob-data Measure a-data Dist a-data Exact--class IntComp repr where-  int                  :: Integer -> repr Integer--class BoolComp repr where-  bool                 :: Bool -> repr Bool--class RealComp repr where-  real                 :: Rational -> repr Real-  exp                  :: repr Real -> repr Real -> repr Real-  sqrt, cos, sin       :: repr Real -> repr Real---- polymorphic operations and integer powering--- probably should restrict 'a' to be some kind of numeric type?-class SymbComp repr where-  add, minus, mul :: repr a -> repr a -> repr a-  pow             :: repr Real -> repr Integer -> repr Real-  scale           :: repr Integer -> repr Real -> repr Real--class MeasMonad repr where-  bind                 :: repr (Measure a) -> (repr a -> repr (Measure b)) -                          -> repr (Measure b)-  ret                  :: repr a -> repr (Measure a)--class Distrib repr where-  uniform, normal :: repr Real -> repr Real -> repr (Dist Real)-  uniformD        :: repr Integer -> repr Integer -> repr (Dist Integer)--class Conditioning repr where-  conditioned, unconditioned :: repr (Dist a) -> repr (Measure a)---- Printer (to Maple)-data Pos = Front | Back-type VarCounter = Int-newtype Maple a = Maple { unMaple :: Pos -> VarCounter -> String }--type family MPL a-type instance MPL Real     = Rational-type instance MPL Integer  = Integer-type instance MPL Bool     = Bool---- if it weren't for the constraints, we could/should use Applicative-pure :: Show (MPL a) => MPL a -> Maple a-pure x = Maple $ \_ _ -> show x--liftA1 :: (String -> String) -> Maple a -> Maple a-liftA1 pr x = Maple $ \f h -> pr (unMaple x f h)--liftA2 :: (String -> String -> String) -> Maple a -> Maple a -> Maple a-liftA2 pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)---- variant for ret-liftA1M :: (String -> String) -> Maple a -> Maple (Measure a)-liftA1M pr x = Maple $ \f h -> pr (unMaple x f h)---- variant for pow-liftA2aba :: (String -> String -> String) -> Maple a -> Maple b -> Maple a-liftA2aba pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)---- variant for scale-liftA2baa :: (String -> String -> String) -> Maple b -> Maple a -> Maple a-liftA2baa pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)--mkPr :: String -> (String -> String)-mkPr s t = s ++ "(" ++ t ++ ")"--d2m :: Maple (Dist a) -> Maple (Measure a)-d2m e = Maple $ unMaple e--infixPr :: String -> (String -> String -> String)-infixPr s a b = a ++ s ++ b---- This is quite scary.  Probably a mistake.-reify :: forall a. Read a => Pos -> VarCounter -> Maple a -> a-reify f h e = (read (unMaple e f h) :: a)--name :: String -> VarCounter -> String-name s h = s ++ show h--var :: String -> VarCounter -> Maple a-var s h = Maple $ \_ _ -> name s h--binder :: (String -> String -> Maybe String) -> -          (String -> String -> VarCounter -> Maybe String) ->-          String -> -          Maple a -> Maple a -> Maple (Dist a)-binder pr1 pr2 oper e1 e2 = Maple $ pr_-  where-    pr_ Front h = let x1 = unMaple e1 Front h-                      x2 = unMaple e2 Front h in-                  case (pr1 x1 x2, pr2 x1 x2 h) of-                    (Just z, Just w)   -> z ++ " * " ++ oper ++ " (" ++ w ++ " * "-                    (Nothing, Just w)  -> oper ++ " (" ++ w ++ " * "-                    (Just z, Nothing)  -> z ++ " * " ++ oper ++ " ("-                    (Nothing, Nothing) -> oper ++ " ("-    pr_ Back h  = ", " ++ (name "x" h) ++ "=" ++ unMaple e1 Back h ++-                  ".." ++ unMaple e2 Back h ++ ")"--instance RealComp Maple where-   -- serious problem here: all exact numbers will be printed as-   -- floats, which will really hamper the use of Maple in any -   -- serious way.  This needs a rethink.-  real  = pure-  exp   = liftA2 $ infixPr "^"-  sqrt  = liftA1 $ mkPr "sqrt"-  cos   = liftA1 $ mkPr "cos"-  sin   = liftA1 $ mkPr "sin"--instance SymbComp Maple where-  add   = liftA2    $ infixPr "+"-  minus = liftA2    $ infixPr "-"-  mul   = liftA2    $ infixPr "*"-  pow   = liftA2aba $ infixPr "^"-  scale = liftA2baa $ infixPr "*"--instance IntComp Maple where-  int  = pure--instance BoolComp Maple where-  bool  = pure--instance MeasMonad Maple where-  ret      = liftA1M $ mkPr "g"-  bind m c = Maple $ \f h -> unMaple m Front h ++ -                             unMaple (c $ var "x" h) f (succ h) ++-                             unMaple m Back h --instance Distrib Maple where-  uniform = binder (\e1 e2 -> Just $ -                     show (1/((read e2 :: Rational) - (read e1 :: Rational)))) -                   (\_ _ _ -> Nothing) "Int"-  uniformD = binder (\e1 e2 -> -                      let d = (read e2 :: Integer) - (read e1) in-                      if d == 1 then Nothing-                      else Just $ "(1 / " ++ show d ++ ")")-                   (\_ _ _ -> Nothing) "Sum"-  normal = binder (\_ _ -> Nothing) -                  (\e1 e2 h -> Just $ "PDF (Normal (" ++ e1 ++ ", " ++ e2 ++ "), " ++ (name "x" h) ++ ")")-                  "Int"--instance Conditioning Maple where-  unconditioned = d2m-  conditioned   = d2m--view :: Maple a -> String-view e = unMaple e Front 0--lift :: Maple Integer -> Maple Real-lift x = Maple $ \f h -> unMaple x f h---- TEST CASES-exp1, exp2, exp3, exp4 :: Maple (Measure Real)-exp1 = unconditioned (uniform (real 1) (real 3)) `bind` ret---- Borel's Paradox Simplified-exp2 = unconditioned (uniformD (int 1) (int 3)) `bind` \s ->-       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->-       let y = s `scale` x in ret y---- Borel's Paradox-exp3 = unconditioned (uniformD (int 1) (int 2)) `bind` \s ->-       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->-       let y = (Language.Hakaru.Symbolic.sqrt ((real 1 ) `minus` -               (Language.Hakaru.Symbolic.pow (lift s) (int 2)))) `mul`-               (Language.Hakaru.Symbolic.sin x) in ret y  --exp4 = unconditioned (normal (real 1) (real 4)) `bind` ret--test, test2, test3, test4 :: String-test = view exp1-test2 = view exp2-test3 = view exp3-test4 = view exp4

@@ -1,31 +0,0 @@-{-# LANGUAGE RankNTypes, DeriveDataTypeable, StandaloneDeriving #-}-{-# OPTIONS -W #-}--module Language.Hakaru.Types where--import Data.Dynamic-import Control.Monad.Primitive-import qualified System.Random.MWC as MWC--type PRNG m = MWC.Gen (PrimState m)---- Basic types for conditioning and conditioned sampler-data Density a = Lebesgue !a | Discrete !a deriving Typeable-type Cond = Maybe Dynamic--fromDiscrete :: Density t -> t-fromDiscrete (Discrete a) = a-fromDiscrete _            = error "got a non-discrete sampler"--fromLebesgue :: Density t -> t-fromLebesgue (Lebesgue a) = a-fromLebesgue  _           = error "got a discrete sampler"--fromDensity :: Density t -> t-fromDensity (Discrete a) = a-fromDensity (Lebesgue a) = a--type LogLikelihood = Double-data Dist a = Dist {logDensity :: Density a -> LogLikelihood,-                    distSample :: (PrimMonad m) => PRNG m -> m (Density a)}-deriving instance Typeable1 Dist

@@ -1,20 +0,0 @@-module Language.Hakaru.Util.Coda where--import Statistics.Autocorrelation-import qualified Data.Packed.Vector as V-import qualified Data.Vector.Generic as G--effectiveSampleSize :: [Double] -> Double-effectiveSampleSize samples = n / (1 + 2*(G.sum rho))-  where n = fromIntegral (V.dim vec)-        vec = V.fromList samples-        cov = autocovariance vec-        rho = G.map (/ G.head cov) cov--meanVariance :: Fractional a => [a] -> (a,a)-meanVariance lst = (av,sigma2)-  where-    n   = fromIntegral $ length lst-    av  = sum lst / n-    sigma2 = (foldr (\x acc -> sqr (x - av) + acc) 0 lst) / (n - 1)-    sqr x = x * x

@@ -1,40 +0,0 @@-{-# LANGUAGE TypeOperators #-}--module Language.Hakaru.Util.Csv ((:::)((:::)), decodeFile, decodeGZipFile,-                 decodeFileStream, decodeGZipFileStream) where--import Data.Csv ( HasHeader(..), FromRecord(..), FromField(..)-                , ToRecord(..), ToField(..), decode)-import qualified Data.Csv.Streaming as CS (decode)-import Codec.Compression.GZip (decompress)-import qualified Data.Foldable as F-import qualified Data.ByteString.Lazy as B-import qualified Data.Vector as V-import Control.Applicative ((<*>), (<$>))--data a ::: b = a ::: b deriving (Eq, Ord, Read, Show)-infixr 5 :::--instance (FromField a, FromRecord b) => FromRecord (a ::: b) where-  parseRecord v | V.null v  = fail "too few fields in input record"-                | otherwise = (:::) <$> parseField (V.head v) <*> parseRecord (V.tail v)--instance (ToField a, ToRecord b) => ToRecord (a ::: b) where-  toRecord (a ::: b) = V.cons (toField a) (toRecord b)--decodeBytes :: FromRecord a => B.ByteString -> [a]-decodeBytes bs = case decode HasHeader bs of-                   Left _ -> []-                   Right v -> V.toList v--decodeFile :: FromRecord a => FilePath -> IO [a]-decodeFile = fmap decodeBytes . B.readFile--decodeGZipFile :: FromRecord a => FilePath -> IO [a]-decodeGZipFile = fmap (decodeBytes . decompress) . B.readFile--decodeFileStream :: FromRecord a => FilePath -> IO [a]-decodeFileStream = fmap (F.toList . CS.decode HasHeader) . B.readFile--decodeGZipFileStream :: FromRecord a => FilePath -> IO [a]-decodeGZipFileStream = fmap (F.toList . CS.decode HasHeader . decompress) . B.readFile

@@ -1,79 +0,0 @@-{-|-  Functions on lists and sequences.-  Some of the functions follow the style of Data.Random.Extras -  (from the random-extras package), but are written for use with-  PRNGs from the "mwc-random" package rather than from the "random-fu" package.--}--module Language.Hakaru.Util.Extras where--import qualified Data.Sequence as S-import qualified System.Random.MWC as MWC-import Data.Maybe-import qualified Data.Foldable as F--extract :: S.Seq a -> Int -> Maybe (S.Seq a, a)-extract s i | S.null r = Nothing-            | otherwise  = Just (a S.>< c, b)-    where (a, r) = S.splitAt i s -          (b S.:< c) = S.viewl r--randomExtract :: S.Seq a -> MWC.GenIO -> IO (Maybe (S.Seq a, a))-randomExtract s g = do-  i <- MWC.uniformR (0, S.length s - 1) g-  return $ extract s i--{-| -  Given a sequence, return a *sorted* sequence of-  n randomly selected elements from *distinct positions* in the sequence--}--randomElems :: Ord a => S.Seq a -> Int -> IO (S.Seq a)-randomElems s n = do -  g <- MWC.create-  randomElemsTR S.empty s g n--randomElemsTR :: Ord a => S.Seq a -> S.Seq a -> MWC.GenIO -> Int -> IO (S.Seq a)-randomElemsTR ixs s g n-    | n == S.length s = return $ S.unstableSort s-    | n == 1 = do (_,i) <- fmap fromJust (randomExtract s g)-                  return.S.unstableSort $ i S.<| ixs-    | otherwise = do (s',i) <- fmap fromJust (randomExtract s g)-                     (randomElemsTR $! (i S.<| ixs)) s' g (n-1)--{-|-  Chop a sequence at the given indices. -  Assume number of indices given < length of sequence to be chopped--}--pieces :: S.Seq a -> S.Seq Int -> [S.Seq a]-pieces s ixs = let f (ps,r,x) y = let (p,r') = S.splitAt (y-x) r-                                  in (p:ps,r',y)-                   g (a,b,_) = b:a-               in g $ F.foldl f ([],s,0) ixs--{-|-  Given n, chop a sequence at m random points-  where m = min (length-1, n-1)--}--randomPieces :: Int -> S.Seq a -> IO [S.Seq a]-randomPieces n s-    | n >= l = return $ F.toList $ fmap S.singleton s-    | otherwise = do ixs <- randomElems (S.fromList [1..l-1]) (n-1)-                     return $ pieces s ixs-    where l = S.length s--{-|-  > pairs [1,2,3,4]-  [(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)]-  > pairs [1,2,4,4]-  [(1,2),(1,4),(1,4),(2,4),(2,4),(4,4)]--}--pairs :: [a] -> [(a,a)]-pairs [] = []-pairs (x:xs) = (zip (repeat x) xs) ++ pairs xs--l2Norm :: Floating a => [a] -> a-l2Norm l = sqrt.sum $ zipWith (*) l l

@@ -1,43 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Language.Hakaru.Util.Visual where--import System.IO-import Control.Monad--import Data.Aeson-import Data.List-import qualified Data.Text as T-import qualified Data.ByteString.Lazy.Char8 as B---import qualified Data.ByteString.Char8 as BS--plot :: Show a => [a] -> String -> IO ()-plot samples filename = do-  h <- openFile filename WriteMode-  hPrint h samples-  hClose h--batchPrint :: Show a => Int -> [a] -> IO ()-batchPrint n l = do-  let batch = take n l-  print batch-  when (length batch == n) $ batchPrint n (drop n l)--viz :: ToJSON a => Int -> [String] -> [[a]] -> IO ()-viz n name samples = viz' n 50 0 name samples--viz' :: ToJSON a => Int -> Int -> Int -> [String] -> [[a]] -> IO ()-viz' n c cur name samples = do-  putStrLn batch-  when (c+cur < n) $-       viz' n c (cur+c) name (drop c samples)-  where-    total = "total_samples" .= n-    current_sample = "current_sample" .= cur-    chunk = object (zipWith (\ name' s -> T.pack name' .= s)-                            name-                            (transpose $ take c samples))-    batch = B.unpack $ encode-            (object ["rvars" .= chunk,-                     total,-                     current_sample])

@@ -1,51 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Tests.Distribution where--import Control.Monad-import qualified System.Random.MWC as MWC--import Language.Hakaru.Types-import Language.Hakaru.Util.Coda-import Language.Hakaru.Distribution hiding (choose)--import Test.QuickCheck-import Test.QuickCheck.Monadic as QM-import Test.Framework.Providers.QuickCheck2 (testProperty)--fromDiscreteToNum = fromIntegral . fromEnum . fromDiscrete-sq x = x * x--almostEqual :: (Num a, Ord a) => a -> a -> a -> Bool-almostEqual tol x y = abs (x - y) < tol--quickArg :: IO ()-quickArg = quickCheckWith stdArgs {maxSuccess = 2000} (\ x -> almostEqual tol x x)-  where tol :: Double-        tol = 1e-5--qtest = [testProperty "checking beta" $ QM.monadicIO betaTest,-         testProperty "checking bern" $ QM.monadicIO bernTest]--betaTest = do-  Positive a <- QM.pick arbitrary-  Positive b <- QM.pick arbitrary-  g <- QM.run $ MWC.create-  samples <- QM.run $ replicateM 1000 $ distSample (beta a b) g-  let (mean, variance) = meanVariance (map fromLebesgue samples)-  QM.assert $ (almostEqual tol mean     (mu  a b)) && -              (almostEqual tol variance (var a b))-  where tol     = 1e-1-        mu a b  = a / (a + b)-        var a b = a*b / ((sq $ a + b) * (a + b + 1))--bernTest = do-   p <- QM.pick $ choose (0, 1)-   g <- QM.run $ MWC.create-   samples <- QM.run $ replicateM 1000 $ distSample (bern p) g-   let (mean, variance) = meanVariance (map fromDiscreteToNum samples)-   QM.assert $ (almostEqual tol mean     (mu  p)) && -               (almostEqual tol variance (var p))-   where tol   = 1e-1-         mu p  = p-         var p = p*(1-p)

@@ -1,119 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Tests.ImportanceSampler where--import Data.Dynamic-import Language.Hakaru.Types-import Language.Hakaru.Lambda-import Language.Hakaru.Distribution-import Language.Hakaru.ImportanceSampler-import qualified System.Random.MWC as MWC---- import Test.QuickCheck.Monadic-import Tests.Models---- Some test programs in our language--test_mixture :: IO ()-test_mixture = MWC.create >>= sample prog_mixture conds >>=-               print . take 10 >>-               putChar '\n' >>-               empiricalMeasure 1000 prog_mixture conds >>=-               print-  where conds = [Just (toDyn (Lebesgue 2 :: Density Double))]--prog_dup :: Measure (Bool, Bool)-prog_dup = do-  let c = unconditioned (bern 0.5)-  x <- c-  y <- c-  return (x,y)--prog_dbn :: Measure Bool-prog_dbn = do-  s0 <- unconditioned (bern 0.75)-  s1 <- unconditioned (if s0 then bern 0.75 else bern 0.25)-  _  <- conditioned   (if s1 then bern 0.90 else bern 0.10)-  s2 <- unconditioned (if s1 then bern 0.75 else bern 0.25)-  _  <- conditioned   (if s2 then bern 0.90 else bern 0.10)-  return s2--test_dbn :: IO ()-test_dbn = MWC.create >>= sample prog_dbn conds >>=-           print . take 10 >>-           putChar '\n' >>-           empiricalMeasure 1000 prog_dbn conds >>=-           print -  where conds = [Just (toDyn (Discrete True)),-                 Just (toDyn (Discrete True))]--prog_hmm :: Integer -> Measure Bool-prog_hmm n = do-  s <- unconditioned (bern 0.75) -  loop_hmm n s--loop_hmm :: Integer -> (Bool -> Measure Bool)-loop_hmm !numLoops s = do-    _ <- conditioned   (if s then bern 0.90 else bern 0.10)-    u <- unconditioned (if s then bern 0.75 else bern 0.25)-    if (numLoops > 1) then loop_hmm (numLoops - 1) u -                      else return s--test_hmm :: IO ()-test_hmm = MWC.create >>= sample (prog_hmm 2) conds >>=-           print . take 10 >>-           putChar '\n' >>-           empiricalMeasure 1000 (prog_hmm 2) conds >>=-           print -  where conds = [Just (toDyn (Discrete True)),-                 Just (toDyn (Discrete True))]--prog_carRoadModel :: Measure (Double, Double)-prog_carRoadModel = do-  speed <- unconditioned (uniform 5 15)-  let z0 = lit 0 -  _ <- conditioned    (normal z0 1)-  z1 <- unconditioned (normal (z0 + speed) 1)-  _ <- conditioned    (normal z1 1)-  z2 <- unconditioned (normal (z1 + speed) 1)	-  _ <- conditioned    (normal z2 1)-  z3 <- unconditioned (normal (z2 + speed) 1)	-  _ <- conditioned    (normal z3 1)-  z4 <- unconditioned (normal (z3 + speed) 1)	-  return (z4, z3)--test_carRoadModel :: IO ()-test_carRoadModel = MWC.create >>= sample prog_carRoadModel conds >>=-                    print . take 10 >>-                    putChar '\n' >>-                    empiricalMeasure 1000 prog_carRoadModel conds >>=-                    print -  where conds = [Just (toDyn (Lebesgue 0  :: Density Double)),-                 Just (toDyn (Lebesgue 11 :: Density Double)), -                 Just (toDyn (Lebesgue 19 :: Density Double)),-                 Just (toDyn (Lebesgue 33 :: Density Double))]--prog_categorical :: Measure Bool-prog_categorical = do -  rain <- unconditioned (categorical [(True, 0.2), (False, 0.8)]) -  sprinkler <- unconditioned (if rain-                              then bern 0.01 else bern 0.4)-  _ <- conditioned (if rain-                    then (if sprinkler then bern 0.99 else bern 0.8)-	            else (if sprinkler then bern 0.90 else bern 0.1))-  return rain--test_categorical :: IO ()-test_categorical = MWC.create >>= sample prog_categorical conds >>=-                   print . take 10 >>-                   putChar '\n' >>-                   empiricalMeasure 1000 prog_categorical conds >>=-                   print -  where conds = [Just (toDyn (Discrete True))]--prog_multiple_conditions :: Measure Double-prog_multiple_conditions = do-  b <- unconditioned (beta 1 1)-  _ <- conditioned (bern b)-  _ <- conditioned (bern b)-  return b

@@ -1,45 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Tests.Metropolis where--import Data.Dynamic--import Language.Hakaru.Types-import Language.Hakaru.Lambda-import Language.Hakaru.Metropolis-import Language.Hakaru.Distribution (bern, normal, uniform, beta)---- import Test.QuickCheck.Monadic--- import Distribution.TestSuite.QuickCheck-import Tests.Models--test_mixture :: IO [Bool]-test_mixture = mcmc prog_mixture [Just (toDyn (Lebesgue (-2) :: Density Double))]--test_multiple_conditions :: IO [Double]-test_multiple_conditions = do-  mcmc prog_multiple_conditions [Just (toDyn (Discrete True)),-                                 Just (toDyn (Discrete False))]--prog_two_normals :: Measure Bool-prog_two_normals = unconditioned (bern 0.5) `bind` \coin ->-       ifThenElse coin (conditioned (normal 0 1))-                       (conditioned (normal 100 1)) `bind` \_ ->-       return coin--test_two_normals :: IO [Bool]-test_two_normals = mcmc prog_two_normals [Just (toDyn (Lebesgue 1 :: Density Double))]--test_normal :: IO [Double]-test_normal = mcmc (unconditioned (normal 1 3)) []--prog_joint =  do-  bias <- unconditioned $ beta 1 1-  coin <- unconditioned $ bern bias-  return (bias, coin)--prog_condition = condition prog_joint True--test_condition :: IO [Double]-test_condition = mcmc prog_condition []-

@@ -1,26 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction, GADTs #-}-module Tests.Models where--import Prelude hiding (Real)--import Language.Hakaru.Syntax2-import Language.Hakaru.Lambda-import qualified Language.Hakaru.Types as T---- if we want to forgo the (D m) constraint, need to decorate the--- program a little more.-prog_mixture :: (Meas m, D m ~ T.Dist ) => m Bool-prog_mixture = do-  c <- unconditioned (bern 0.5)-  _ <- conditioned (ifThenElse c (normal 1 1)-                                 (uniform 0 3))-  return c--prog_multiple_conditions :: (Meas m, D m ~ T.Dist) => m Double-prog_multiple_conditions = do-  b <- unconditioned (beta 1 1)-  _ <- conditioned (bern b)-  _ <- conditioned (bern b)-  return b--

@@ -1,24 +0,0 @@-module Main where--import Prelude hiding (Real)--import qualified Tests.ImportanceSampler as IS-import qualified Tests.Metropolis as MH-import qualified Tests.Distribution as D--import Language.Hakaru.Syntax2-import Language.Hakaru.Lambda-import qualified Language.Hakaru.Types as T--import Test.Framework (defaultMain, testGroup)-import Test.Framework.Providers.HUnit--import Test.HUnit--tests = [-        testGroup "Distribution checks" D.qtest,   -        testCase "alwaysPass" (1 @?= 1)-        --testCase "alwaysFail" (error "Fail!")-    ]--main = defaultMain tests

@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings,+             PatternGuards,+             DataKinds,+             KindSignatures,+             GADTs,+             FlexibleContexts,+             TypeOperators+             #-}++module Main where++import qualified Language.Hakaru.Syntax.AST as T+import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.ABT+import           Language.Hakaru.Syntax.TypeCheck++import           Language.Hakaru.Syntax.IClasses+import           Language.Hakaru.Types.Sing+import           Language.Hakaru.Types.DataKind++import           Language.Hakaru.Pretty.Haskell+import           Language.Hakaru.Command (parseAndInfer)++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)+import           Text.PrettyPrint++import           System.Environment+import           System.FilePath++data Options = Options+  { program  :: String+  , asFunc   :: Maybe String+  }++main :: IO ()+main = do+  args   <- getArgs+  case args of+      [prog1, prog2] -> compileRandomWalk prog1 prog2+      [prog]         -> compileHakaru     prog+      _              -> IO.hPutStrLn stderr+                          "Usage: compile <file>\n\+                          \     | compile <transition_kernel> <initial_measure>"++prettyProg :: (ABT T.Term abt)+           => String+           -> abt '[] a+           -> String+prettyProg name ast =+    renderStyle style+    (cat [ text (name ++ " = ")+         , nest 2 (pretty ast)+         ])++compileHakaru :: String -> IO ()+compileHakaru file = do+    prog <- IO.readFile file+    let target = replaceFileName file (takeBaseName file) ++ ".hs"+    case parseAndInfer prog of+      Left err                 -> IO.hPutStrLn stderr err+      Right (TypedAST typ ast) -> do+        IO.writeFile target . Data.Text.unlines $+          header +++          [ pack $ prettyProg "prog" (et ast) ] +++          footer typ+  where et = expandTransformations++compileRandomWalk :: String -> String -> IO ()+compileRandomWalk f1 f2 = do+    p1 <- IO.readFile f1+    p2 <- IO.readFile f2+    let output = replaceFileName f1 (takeBaseName f1) ++ ".hs"+    case (parseAndInfer p1, parseAndInfer p2) of+      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->+          -- TODO: Use better error messages for type mismatch+          case (typ1, typ2) of+            (SFun a (SMeasure b), SMeasure c)+              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)+              -> IO.writeFile output . Data.Text.unlines $+                   header +++                   [ pack $ prettyProg "prog1" (expandTransformations ast1) ] +++                   [ pack $ prettyProg "prog2" (expandTransformations ast2) ] +++                   footerWalk+            _ -> IO.hPutStrLn stderr "compile: programs have wrong type"+      (Left err, _) -> IO.hPutStrLn stderr err+      (_, Left err) -> IO.hPutStrLn stderr err++header :: [Text]+header =+  [ "{-# LANGUAGE DataKinds, NegativeLiterals #-}"+  , "module Main where"+  , ""+  , "import           Prelude                          hiding (product)"+  , "import           Language.Hakaru.Runtime.Prelude"+  , "import           Language.Hakaru.Types.Sing"+  , "import qualified System.Random.MWC                as MWC"+  , "import           Control.Monad"+  , ""+  ]++footer :: Sing (a :: Hakaru) -> [Text]+footer typ =+  [ ""+  , "main :: IO ()"+  , "main = do"+  , "  g <- MWC.createSystemRandom"+  , case typ of+      SMeasure _ -> "  forever $ run g prog"+      _          -> "  print prog"+  ]++footerWalk :: [Text]+footerWalk =+  [ ""+  , "main :: IO ()"+  , "main = do"+  , "  g <- MWC.createSystemRandom"+  , "  x <- prog2 g"+  , "  iterateM_ (withPrint $ flip prog1 g) x"+  ]

@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete+import           Language.Hakaru.Syntax.TypeCheck++import           Language.Hakaru.Types.Sing+import           Language.Hakaru.Disintegrate+import           Language.Hakaru.Evaluation.ConstantPropagation+import           Language.Hakaru.Command++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args  <- getArgs+  progs <- mapM readFromFile args+  case progs of+      [prog] -> runDensity prog+      _      -> IO.hPutStrLn stderr "Usage: density <file>"++runDensity :: Text -> IO ()+runDensity prog =+    case parseAndInfer prog of+    Left  err                -> IO.hPutStrLn stderr err+    Right (TypedAST typ ast) ->+        case typ of+            SMeasure _ ->+                case determine (density ast) of+                  Just ast' -> print . pretty $ constantPropagation ast'+                  Nothing   -> IO.hPutStrLn stderr "No density found"+            _               -> IO.hPutStrLn stderr "Density is only available for measure terms"+

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings, PatternGuards, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Syntax.IClasses++import           Language.Hakaru.Types.Sing+import           Language.Hakaru.Disintegrate+import           Language.Hakaru.Evaluation.ConstantPropagation+import           Language.Hakaru.Command++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args  <- getArgs+  progs <- mapM readFromFile args+  case progs of+      [prog] -> runDisintegrate prog+      _      -> IO.hPutStrLn stderr "Usage: disintegrate <file>"++runDisintegrate :: Text -> IO ()+runDisintegrate prog =+    case parseAndInfer prog of+    Left  err                -> IO.hPutStrLn stderr err+    Right (TypedAST typ ast) ->+        case typ of+          SMeasure (SData (STyCon sym `STyApp` _ `STyApp` _) _)+            | Just Refl <- jmEq1 sym sSymbol_Pair+            -> case determine (disintegrate ast) of+               Just ast' -> print . pretty $ constantPropagation ast'+               Nothing   -> IO.hPutStrLn stderr "No disintegration found"+          _ -> IO.hPutStrLn stderr "Can only disintegrate a measure over pairs"+

@@ -0,0 +1,132 @@+{-# LANGUAGE GADTs,+             OverloadedStrings #-}++module Main where++import Language.Hakaru.Evaluation.ConstantPropagation+import Language.Hakaru.Syntax.TypeCheck+import Language.Hakaru.Syntax.AST.Transforms (expandTransformations)+import Language.Hakaru.Command+import Language.Hakaru.CodeGen.Wrapper+import Language.Hakaru.CodeGen.CodeGenMonad+import Language.Hakaru.CodeGen.AST+import Language.Hakaru.CodeGen.Pretty++import           Control.Monad.Reader+import           Data.Text hiding (any,map,filter,foldr)+import qualified Data.Text.IO as IO+import           Text.PrettyPrint (render)+import           Options.Applicative+import           System.IO+import           System.Process+import           System.Exit+import           Prelude hiding (concat)++data Options =+ Options { debug            :: Bool+         , optimize         :: Bool+         , make             :: Maybe String+         , asFunc           :: Maybe String+         , fileIn           :: String+         , fileOut          :: Maybe String+         , par              :: Bool+         , showWeightsOpt   :: Bool+         , showProbInLogOpt :: Bool+         } deriving Show+++main :: IO ()+main = do+  opts <- parseOpts+  prog <- readFromFile (fileIn opts)+  runReaderT (compileHakaru prog) opts++options :: Parser Options+options = Options+  <$> switch (  long "debug"+             <> short 'D'+             <> help "Prints Hakaru src, Hakaru AST, C AST, C src" )+  <*> switch (  long "optimize"+             <> short 'O'+             <> help "Performs constant folding on Hakaru AST" )+  <*> (optional $ strOption (  long "make"+                            <> short 'm'+                            <> help "Compiles generated C code with the compiler ARG"))+  <*> (optional $ strOption (  long "as-function"+                            <> short 'F'+                            <> help "Compiles to a sampling C function with the name ARG" ))+  <*> strArgument (  metavar "INPUT"+                  <> help "Program to be compiled")+  <*> (optional $ strOption (  short 'o'+                            <> metavar "OUTPUT"+                            <> help "output FILE"))+  <*> switch (  short 'j'+             <> help "Generates parallel programs using OpenMP directives")+  <*> switch (  long "show-weights"+             <> short 'w'+             <> help "Shows the weights along with the samples in samplers")+  <*> switch (  long "show-prob-log"+             <> help "Shows prob types as 'exp(<log-domain-value>)' instead of '<value>'")++parseOpts :: IO Options+parseOpts = execParser $ info (helper <*> options)+                       $ fullDesc <> progDesc "Compile Hakaru to C"++compileHakaru :: Text -> ReaderT Options IO ()+compileHakaru prog = ask >>= \config -> lift $ do+  case parseAndInfer prog of+    Left err -> IO.hPutStrLn stderr err+    Right (TypedAST typ ast) -> do+      let ast'    = TypedAST typ $ foldr id ast abtPasses+          outPath = case fileOut config of+                      (Just f) -> f+                      Nothing  -> "-"+          codeGen = wrapProgram ast'+                                (asFunc config)+                                (PrintConfig { showWeights   = showWeightsOpt config+                                             , showProbInLog = showProbInLogOpt config })+          cast    = CAST $ runCodeGenWith codeGen (emptyCG {parallel = par config})+          output  = pack . render . pretty $ cast+      when (debug config) $ do+        putErrorLn $ hrule "Hakaru Type"+        putErrorLn . pack . show $ typ+        when (optimize config) $ do+          putErrorLn $ hrule "Hakaru AST"+          putErrorLn $ pack $ show ast+        putErrorLn $ hrule "Hakaru AST'"+        putErrorLn $ pack $ show ast+        putErrorLn $ hrule "C AST"+        putErrorLn $ pack $ show cast+        putErrorLn $ hrule "Fin"+      case make config of+        Nothing -> writeToFile outPath output+        Just cc -> makeFile cc (fileOut config) (unpack output) config++  where hrule s = concat ["\n<=======================| "+                         ,s," |=======================>\n"]+        abtPasses = [ expandTransformations+                    , constantPropagation ]++putErrorLn :: Text -> IO ()+putErrorLn = IO.hPutStrLn stderr+++makeFile :: String -> Maybe String -> String -> Options -> IO ()+makeFile cc mout prog opts =+  do let p = proc cc $ ["-pedantic"+                       ,"-std=c99"+                       ,"-lm"+                       ,"-xc"+                       ,"-"]+                       ++ (case mout of+                            Nothing -> []+                            Just o  -> ["-o" ++ o])+                       ++ (if par opts then ["-fopenmp"] else [])+     (Just inH, _, _, pH) <- createProcess p { std_in    = CreatePipe+                                             , std_out   = CreatePipe }+     hPutStrLn inH prog+     hClose inH+     exit <- waitForProcess pH+     case exit of+       ExitSuccess -> return ()+       _           -> error $ cc ++ " returned exit code: " ++ show exit

@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings,+             PatternGuards,+             DataKinds,+             GADTs,+             TypeOperators+             #-}++module Main where++import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Syntax.Value++import           Language.Hakaru.Syntax.IClasses+import           Language.Hakaru.Types.Sing+import           Language.Hakaru.Types.DataKind++import           Language.Hakaru.Sample+import           Language.Hakaru.Pretty.Concrete+import           Language.Hakaru.Command (parseAndInfer, readFromFile, Term)++import           Control.Monad++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)+import           Text.PrettyPrint (renderStyle, style, mode, Mode(LeftMode))++import qualified System.Random.MWC as MWC+import           System.Environment++main :: IO ()+main = do+  args   <- getArgs+  g      <- MWC.createSystemRandom+  progs  <- mapM readFromFile args+  case progs of+      [prog1, prog2] -> randomWalk g prog1 prog2+      [prog]         -> runHakaru  g prog+      _              -> IO.hPutStrLn stderr+                          "Usage: hakaru <file>\n\+                          \     | hakaru <transition_kernel> <initial_measure>"++illustrate :: Sing a -> MWC.GenIO -> Value a -> IO ()+illustrate (SMeasure s) g (VMeasure m) = do+    x <- m (VProb 1) g+    case x of+      Just (samp, _) -> illustrate s g samp+      Nothing        -> illustrate (SMeasure s) g (VMeasure m)++illustrate _ _ x = render x++render :: Value a -> IO ()+render = putStrLn . renderStyle style {mode = LeftMode} . prettyValue++runHakaru :: MWC.GenIO -> Text -> IO ()+runHakaru g prog =+    case parseAndInfer prog of+      Left err                 -> IO.hPutStrLn stderr err+      Right (TypedAST typ ast) -> do+        case typ of+          SMeasure _ -> forever (illustrate typ g $ run ast)+          _          -> illustrate typ g $ run ast+    where+    run :: Term a -> Value a+    run = runEvaluate . expandTransformations++randomWalk ::MWC.GenIO -> Text -> Text -> IO ()+randomWalk g p1 p2 =+    case (parseAndInfer p1, parseAndInfer p2) of+      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->+          -- TODO: Use better error messages for type mismatch+          case (typ1, typ2) of+            (SFun a (SMeasure b), SMeasure c)+              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)+              -> iterateM_ (chain $ run ast1) (run ast2)+            _ -> IO.hPutStrLn stderr "hakaru: programs have wrong type"+      (Left err, _) -> IO.hPutStrLn stderr err+      (_, Left err) -> IO.hPutStrLn stderr err+    where+    run :: Term a -> Value a+    run = runEvaluate . expandTransformations++    chain :: Value (a ':-> b) -> Value ('HMeasure a) -> IO (Value b)+    chain (VLam f) (VMeasure m) = do+      Just (samp,_) <- m (VProb 1) g+      render samp+      return (f samp)++-- From monad-loops+iterateM_ :: Monad m => (a -> m a) -> a -> m b+iterateM_ f = g+    where g x = f x >>= g

@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, PatternGuards, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete  +import           Language.Hakaru.Syntax.TypeCheck++import           Language.Hakaru.Syntax.IClasses+import           Language.Hakaru.Types.Sing+import           Language.Hakaru.Inference+import           Language.Hakaru.Command+  +import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args  <- getArgs+  progs <- mapM readFromFile args+  case progs of+      [prog2, prog1] -> runMH prog1 prog2+      _              -> IO.hPutStrLn stderr "Usage: mh <target> <proposal>"++runMH :: Text -> Text -> IO ()+runMH prog1 prog2 =+    case (parseAndInfer prog1, parseAndInfer prog2) of+      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->+          -- TODO: Use better error messages for type mismatch+          case (typ1, typ2) of+            (SFun a (SMeasure b), SMeasure c)+              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)+              -> print . pretty $ mcmc ast1 ast2+            _ -> IO.hPutStrLn stderr "mh: programs have wrong type"+      (Left err, _) -> IO.hPutStrLn stderr err+      (_, Left err) -> IO.hPutStrLn stderr err

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}++module Main where++import qualified Language.Hakaru.Pretty.Maple as Maple+import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Command++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args <- getArgs+  case args of+      [prog] -> IO.readFile prog >>= runPretty+      []     -> IO.getContents   >>= runPretty+      _      -> IO.hPutStrLn stderr "Usage: momiji <file>"++runPretty :: Text -> IO ()+runPretty prog =+    case parseAndInfer prog of+    Left  err              -> IO.hPutStrLn stderr err+    Right (TypedAST typ ast) -> do+      putStrLn $ Maple.pretty (expandTransformations ast)+      putStrLn $ ","+      putStrLn $ Maple.mapleType typ ""+

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete  +import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Types.Sing++import           Language.Hakaru.Expect (normalize)+import           Language.Hakaru.Evaluation.ConstantPropagation+import           Language.Hakaru.Command++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args <- getArgs+  case args of+      [prog] -> IO.readFile prog >>= runNormalize+      []     -> IO.getContents   >>= runNormalize+      _      -> IO.hPutStrLn stderr "Usage: normalize <file>"++runNormalize :: Text -> IO ()+runNormalize prog = either (IO.hPutStrLn stderr) print $ do+  TypedAST typ ast <- parseAndInfer prog+  res <- normalizeUnderLams typ ast+  return (pretty res)++normalizeUnderLams :: Sing a -> Term a -> Either Text (Term a)+normalizeUnderLams (SMeasure _) ast = Right . constantPropagation . normalize $ ast+normalizeUnderLams (SFun _ typ) ast = underLam (normalizeUnderLams typ) ast+normalizeUnderLams _            _   = Left "Can only normalize measures"

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete+import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Command++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import           System.Environment++main :: IO ()+main = do+  args <- getArgs+  case args of+      [prog] -> IO.readFile prog >>= runPretty+      []     -> IO.getContents   >>= runPretty+      _      -> IO.hPutStrLn stderr "Usage: pretty <file>"++runPretty :: Text -> IO ()+runPretty prog =+    case parseAndInfer prog of+    Left  err              -> IO.hPutStrLn stderr err+    Right (TypedAST _ ast) -> print . pretty . expandTransformations $ ast+

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, OverloadedStrings, DataKinds, GADTs #-}++module Main where++import           Language.Hakaru.Pretty.Concrete  +import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Command (parseAndInfer, readFromFile, Term)++import           Language.Hakaru.Simplify++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative   (Applicative(..), (<$>))+#endif++import           Data.Text+import qualified Data.Text.IO as IO+import           System.IO (stderr)++import qualified Options.Applicative as O++data Options = Options+  { debug   :: Bool+  , program :: String }++options :: O.Parser Options+options = Options+  <$> O.switch+      ( O.long "debug" O.<>+        O.help "Prints output that is sent to Maple" )+  <*> O.strArgument+      ( O.metavar "PROGRAM" O.<> +        O.help "Program to be simplified" )++parseOpts :: IO Options+parseOpts = O.execParser $ O.info (O.helper <*> options)+      (O.fullDesc O.<> O.progDesc "Simplify a hakaru program")++et :: Term a -> Term a+et = expandTransformations++main :: IO ()+main = do+  args <- parseOpts+  case args of+   Options debug_ file -> do+    prog <- readFromFile file+    runSimplify prog debug_++runSimplify :: Text -> Bool -> IO ()+runSimplify prog debug_ =+    case parseAndInfer prog of+    Left  err              -> IO.hPutStrLn stderr err+    Right (TypedAST _ ast) -> simplifyDebug debug_ (et ast) >>= print . pretty+

@@ -1,99 +1,281 @@--- Initial hakaru.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/+-- To understand this, see http://haskell.org/cabal/users-guide/ +cabal-version:       >=1.16+build-type:          Simple name:                hakaru-version:             0.1.4-synopsis:            A probabilistic programming embedded DSL   --- description:         +version:             0.3.0+synopsis:            A probabilistic programming language+description:         Hakaru is a simply-typed probabilistic programming language, designed+                     for easy specification of probabilistic models, and inference algorithms. homepage:            http://indiana.edu/~ppaml/ license:             BSD3 license-file:        LICENSE author:              The Hakaru Team maintainer:          ppaml@indiana.edu--- copyright:           +-- copyright: category:            Language-build-type:          Simple--- extra-source-files:  -cabal-version:       >=1.10+-- extra-source-files: -library-  exposed-modules:     Language.Hakaru.Types,-                       Language.Hakaru.Symbolic,-                       Language.Hakaru.Arrow,-                       Language.Hakaru.Mixture,-                       Language.Hakaru.Sampler,-                       Language.Hakaru.ImportanceSampler,-                       Language.Hakaru.Metropolis,-                       Language.Hakaru.Lambda,-                       Language.Hakaru.Distribution,-                       Language.Hakaru.Util.Csv,-                       Language.Hakaru.Util.Extras,-                       Language.Hakaru.Util.Visual,-                       Language.Hakaru.Util.Coda-  other-extensions:    RankNTypes, BangPatterns, GADTs, TypeFamilies, TypeOperators,-                       ConstraintKinds, FlexibleContexts, NoMonomorphismRestriction,-                       DeriveDataTypeable, ScopedTypeVariables, ExistentialQuantification,-                       StandaloneDeriving, OverloadedStrings,-                       FlexibleInstances, RebindableSyntax-  build-depends:       base >=4.6 && <5.0,-                       random >=1.0 && <1.1,-                       transformers >=0.3 && <0.4,-                       containers >=0.5 && <0.6,-                       pretty >=1.1 && <1.2,-                       logfloat >=0.12 && <0.13,-                       hmatrix >=0.16 && <0.17,-                       math-functions >=0.1 && <0.2,-                       vector >=0.10 && <0.11,-                       cassava >=0.4 && <0.5,-                       zlib >=0.5 && <0.6,-                       bytestring >=0.10 && <0.11,-                       aeson >=0.7 && <0.8,-                       text >=1.1 && <1.2,-                       statistics >=0.11 && <0.14,-                       parsec >=3.1 && <3.2,-                       array >=0.4,-                       mwc-random >=0.13 && <0.14,-                       directory >=1.2 && <1.3,-                       integration >= 0.2.0 && < 0.3.0,-                       primitive >= 0.5 && < 0.6,-                       parallel >=3.2 && <3.3,-                       monad-loops >= 0.3.0.2-  -- hs-source-dirs:      -  default-language:    Haskell2010-  ghc-options:         -Wall+----------------------------------------------------------------+Source-Repository head+    Type:     git+    Location: https://github.com/hakaru-dev/hakaru -test-suite hakaru-test-    type:              exitcode-stdio-1.0-    main-is:           Tests/Tests.hs-    other-modules:     Tests.ImportanceSampler,-                       Tests.Models,-                       Tests.Metropolis,-                       Tests.Distribution-    build-depends:     base, Cabal >= 1.10, -                       QuickCheck, -                       HUnit,-                       test-framework,-                       test-framework-quickcheck2,-                       test-framework-hunit,-                       random >=1.0 && <1.1,-                       pretty >=1.1 && <1.2,-                       containers >=0.5 && <0.6,-                       logfloat >=0.12 && <0.13,-                       math-functions >=0.1 && <0.2,-                       statistics >=0.11 && <0.14,-                       hmatrix >=0.16 && <0.17,-                       vector >=0.10 && <0.11,-                       hakaru >= 0.1.3,-                       mwc-random >=0.13 && <0.14,-                       primitive >= 0.5 && < 0.6,-                       monad-loops >= 0.3.0.2-    default-language:  Haskell2010+----------------------------------------------------------------+Flag traceDisintegrate+    Default:     False+    Description: Insert tracing code to help debug disintegration. -benchmark bench-all-    type:              exitcode-stdio-1.0-    hs-source-dirs:    Bench-    main-is:           Bench.hs-    build-depends:     base, deepseq, ghc-prim,-                       criterion, hakaru >= 0.1.3-    ghc-options:       -O2-    default-language:  Haskell2010+----------------------------------------------------------------+Library+    Hs-Source-Dirs:    haskell+    Default-Language:  Haskell2010+    GHC-Options:       -Wall -fwarn-tabs -j6++    if flag(traceDisintegrate)+        Cpp-Options:   -D__TRACE_DISINTEGRATE__++    exposed-modules:   Language.Hakaru.Syntax.IClasses,+                       Language.Hakaru.Syntax.ABT,+                       Language.Hakaru.Syntax.Variable,+                       Language.Hakaru.Syntax.Value,+                       Language.Hakaru.Syntax.Datum,+                       Language.Hakaru.Syntax.DatumABT,+                       Language.Hakaru.Syntax.DatumCase,+                       Language.Hakaru.Types.DataKind,+                       Language.Hakaru.Types.Sing,+                       Language.Hakaru.Types.HClasses,+                       Language.Hakaru.Types.Coercion,+                       Language.Hakaru.Syntax.AST,+                       Language.Hakaru.Syntax.AST.Transforms,+                       Language.Hakaru.Syntax.AST.Sing,+                       Language.Hakaru.Syntax.AST.Eq,+                       Language.Hakaru.Syntax.TypeCheck,+                       Language.Hakaru.Syntax.TypeOf,+                       Language.Hakaru.Syntax.Prelude,+                       Language.Hakaru.Parser.AST,+                       Language.Hakaru.Parser.Maple,+                       Language.Hakaru.Parser.Parser,+                       Language.Hakaru.Parser.SymbolResolve,+                       Language.Hakaru.Pretty.Haskell,+                       Language.Hakaru.Pretty.Concrete,+                       Language.Hakaru.Pretty.Maple,+                       Language.Hakaru.Runtime.Prelude,+                       Language.Hakaru.Observe,+                       Language.Hakaru.Simplify,+                       Language.Hakaru.Sample,+                       Language.Hakaru.Evaluation.Types,+                       Language.Hakaru.Evaluation.Lazy,+                       Language.Hakaru.Evaluation.PEvalMonad,+                       Language.Hakaru.Evaluation.EvalMonad+                       Language.Hakaru.Evaluation.ConstantPropagation,+                       Language.Hakaru.Evaluation.DisintegrationMonad,+                       Language.Hakaru.Evaluation.Coalesce,+                       Language.Hakaru.Disintegrate,+                       Language.Hakaru.Evaluation.ExpectMonad,+                       Language.Hakaru.Expect,+                       Language.Hakaru.Inference,+                       Language.Hakaru.Command,+                       Language.Hakaru.CodeGen.Wrapper,+                       Language.Hakaru.CodeGen.Flatten,+                       Language.Hakaru.CodeGen.CodeGenMonad,+                       Language.Hakaru.CodeGen.Types,+                       Language.Hakaru.CodeGen.AST,+                       Language.Hakaru.CodeGen.Pretty,+                       Data.Number.Nat,+                       Data.Number.Natural++    other-modules:     System.MapleSSH++    build-depends:     base               >= 4.7  && < 5.0,+                       Cabal              >= 1.16,+                       ghc-prim           >= 0.3  && < 0.6,+                       transformers       >= 0.3  && < 0.6,+                       containers         >= 0.5  && < 0.6,+                       semigroups         >= 0.16,+                       pretty             >= 1.1  && < 1.2,+                       logfloat           >= 0.13 && < 0.14,+                       math-functions     >= 0.1  && < 0.3,+                       vector             >= 0.10,+                       indentation-parsec >= 0.0,+                       ansi-terminal      >= 0.6,+                       text               >= 0.11 && < 1.3,+                       parsec             >= 3.1  && < 3.2,+                       mwc-random         >= 0.13 && < 0.14,+                       directory          >= 1.2  && < 1.3,+                       integration        >= 0.2.0 && < 0.3.0,+                       primitive          >= 0.5  && < 0.7,+                       process            >= 1.1  && < 2.0,+                       HUnit              >= 1.2  && < 2.0,+                       mtl                >= 2.1,+                       filepath           >= 1.1.0.2++----------------------------------------------------------------+Test-Suite system-testsuite+    Type:              exitcode-stdio-1.0+    Main-is:           Tests/TestSuite.hs+    Hs-Source-Dirs:    haskell+    Default-Language:  Haskell2010+    GHC-Options:       -Wall -fwarn-tabs++    Build-Depends:     base               >= 4.6  && < 5.0,+                       Cabal              >= 1.16,+                       ghc-prim           >= 0.3  && < 0.6,+                       indentation-parsec >= 0.0,+                       transformers       >= 0.3  && < 0.6,+                       containers         >= 0.5  && < 0.6,+                       semigroups         >= 0.16,+                       logfloat           >= 0.13 && < 0.14,+                       parsec             >= 3.1  && < 3.2,+                       primitive          >= 0.5  && < 0.7,+                       pretty             >= 1.1  && < 1.2,+                       mwc-random         >= 0.13 && < 0.14,+                       math-functions     >= 0.1  && < 0.3,+                       integration        >= 0.2  && < 0.3,+                       ansi-terminal      >= 0.6,+                       HUnit              >= 1.2  && < 2.0,+                       QuickCheck         >= 2.6,+                       process            >= 1.1  && < 2.0,+                       mtl                >= 2.1,+                       vector             >= 0.10,+                       text               >= 0.11 && < 1.3++----------------------------------------------------------------+Executable hakaru+    Main-is:           Hakaru.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3++----------------------------------------------------------------+Executable compile+    Main-is:           Compile.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       pretty           >= 1.1  && < 1.2,+                       filepath         >= 1.3,+                       hakaru           >= 0.3++----------------------------------------------------------------+Executable simplify+    Main-is:           Simplify.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base                 >= 4.7  && < 5.0,+                       mwc-random           >= 0.13 && < 0.14,+                       text                 >= 0.11 && < 1.3,+                       pretty               >= 1.1  && < 1.2,+                       optparse-applicative >= 0.11 && < 0.13,+                       hakaru               >= 0.3++----------------------------------------------------------------+Executable density+    Main-is:           Density.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3+ +----------------------------------------------------------------+Executable disintegrate+    Main-is:           Disintegrate.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3++----------------------------------------------------------------+Executable pretty+    Main-is:           Pretty.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       text             >= 0.11 && < 1.3,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3++----------------------------------------------------------------+Executable momiji+    Main-is:           Momiji.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       text             >= 0.11 && < 1.3,+                       hakaru           >= 0.3++----------------------------------------------------------------+Executable normalize+    Main-is:           Normalize.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       mtl              >= 2.1,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3+++----------------------------------------------------------------+Executable hkc+    Main-is:           HKC.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base                 >= 4.7  && < 5.0,+                       containers           >= 0.5  && < 0.6,+                       text                 >= 0.11 && < 1.3,+                       mtl                  >= 2.1,+                       optparse-applicative >= 0.11 && < 0.13,+                       pretty               >= 1.1  && < 1.2,+                       process              >= 1.1  && < 2.0,+                       hakaru               >= 0.3,+                       semigroups           >= 0.16+++----------------------------------------------------------------+Executable mh+    Main-is:           Mh.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base             >= 4.7  && < 5.0,+                       mwc-random       >= 0.13 && < 0.14,+                       text             >= 0.11 && < 1.3,+                       mtl              >= 2.1,+                       pretty           >= 1.1  && < 1.2,+                       hakaru           >= 0.3++----------------------------------------------------------------+----------------------------------------------------------- fin.

@@ -0,0 +1,165 @@+-- TODO: merge with the Posta version. And release them as a standalone package+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+----------------------------------------------------------------+--                                                    2015.12.17+-- |+-- Module      :  Data.Number.Nat+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  wren@community.haskell.org+-- Stability   :  experimental+-- Portability :  Haskell98 + CPP+--+-- A data type for natural numbers (aka non-negative integers).+----------------------------------------------------------------+module Data.Number.Nat+    ( Nat()+    , fromNat+    , toNat+    , unsafeNat+    , MaxNat(..)+    ) where++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+#endif++----------------------------------------------------------------+----------------------------------------------------------------+-- | Natural numbers, with fixed-width à la 'Int'. N.B., the 'Num'+-- instance will throw errors on subtraction, negation, and+-- 'fromInteger' when the result is not a natural number.+newtype Nat = Nat Int+    deriving (Eq, Ord, Show)++-- TODO: should we define our own Show instance, in order to just+-- show the Int itself, relying on our 'fromInteger' definition to+-- preserve cut&paste-ability? If so, then we should ensure that+-- the Read instance is optional in whether the \"Nat\" is there+-- or not.++-- N.B., we cannot derive Read, since that would inject invalid numbers!+instance Read Nat where+    readsPrec d =+        readParen (d > 10) $ \s0 -> do+            ("Nat", s1) <- lex s0+            (i,     s2) <- readsPrec 11 s1+            maybe [] (\n -> [(n,s2)]) (toNat i)+++-- | Safely convert a natural number to an integer.+fromNat :: Nat -> Int+fromNat (Nat i) = i+{-# INLINE fromNat #-}+++-- | Safely convert an integer to a natural number. Returns @Nothing@+-- if the integer is negative.+toNat :: Int -> Maybe Nat+toNat x+    | x < 0     = Nothing+    | otherwise = Just (Nat x)+{-# INLINE toNat #-}+++-- | Unsafely convert an integer to a natural number. Throws an+-- error if the integer is negative.+unsafeNat :: Int -> Nat+unsafeNat x+    | x < 0     = error _errmsg_unsafeNat+    | otherwise = Nat x+{-# INLINE unsafeNat #-}+++instance Num Nat where+    Nat i + Nat j   = Nat (i + j)+    Nat i * Nat j   = Nat (i * j)+    Nat i - Nat j+        | i >= j    = Nat (i - j)+        | otherwise = error _errmsg_subtraction+    negate _        = error _errmsg_negate+    abs n           = n+    signum _        = Nat 1+    fromInteger i+        | i >= 0 && n >= 0 = Nat n+        | otherwise = error _errmsg_fromInteger+        where+        n :: Int+        n = fromInteger i+    {-# INLINE (+) #-}+    {-# INLINE (*) #-}+    {-# INLINE (-) #-}+    {-# INLINE negate #-}+    {-# INLINE abs #-}+    {-# INLINE signum #-}+    {-# INLINE fromInteger #-}++instance Enum Nat where+    succ (Nat i) = if i /= maxBound then Nat (i+1) else error _errmsg_succ+    pred (Nat i) = if i /= 0        then Nat (i-1) else error _errmsg_pred+    toEnum n     = if n >= 0        then Nat n     else error _errmsg_toEnum+    fromEnum (Nat i) = i++    enumFrom       (Nat i)                 = map Nat (enumFrom       i)+    enumFromThen   (Nat i) (Nat j)         = map Nat (enumFromThen   i j)+    enumFromTo     (Nat i)         (Nat k) = map Nat (enumFromTo     i   k)+    enumFromThenTo (Nat i) (Nat j) (Nat k) = map Nat (enumFromThenTo i j k)+    {-# INLINE succ #-}+    {-# INLINE pred #-}+    {-# INLINE toEnum #-}+    {-# INLINE fromEnum #-}+    {-# INLINE enumFrom #-}+    {-# INLINE enumFromThen #-}+    {-# INLINE enumFromTo #-}+    {-# INLINE enumFromThenTo #-}++instance Real Nat where+    toRational (Nat i) = toRational i+    {-# INLINE toRational #-}++instance Integral Nat where+    quot    (Nat i) (Nat j) = Nat (quot i j)+    rem     (Nat i) (Nat j) = Nat (rem  i j)+    quotRem (Nat i) (Nat j) = case quotRem i j of (q,r) -> (Nat q, Nat r)+    div    = quot+    mod    = rem+    divMod = quotRem+    toInteger (Nat i) = toInteger i+    {-# INLINE quot #-}+    {-# INLINE rem #-}+    {-# INLINE div #-}+    {-# INLINE mod #-}+    {-# INLINE quotRem #-}+    {-# INLINE divMod #-}+    {-# INLINE toInteger #-}+++----------------------------------------------------------------+newtype MaxNat = MaxNat { unMaxNat :: Nat }++instance Monoid MaxNat where+    mempty                        = MaxNat 0+    mappend (MaxNat m) (MaxNat n) = MaxNat (max m n)+++----------------------------------------------------------------+_errmsg_unsafeNat, _errmsg_subtraction, _errmsg_negate, _errmsg_fromInteger, _errmsg_succ, _errmsg_pred, _errmsg_toEnum+    :: String+_errmsg_unsafeNat   = "unsafeNat: negative input"+_errmsg_subtraction = "(-)@Nat: Num is a bad abstraction"+_errmsg_negate      = "negate@Nat: Num is a bad abstraction"+_errmsg_fromInteger = "fromInteger@Nat: Num is a bad abstraction"+_errmsg_succ        = "succ@Nat: No successor of the maxBound"+_errmsg_pred        = "pred@Nat: No predecessor of zero"+_errmsg_toEnum      = "toEnum@Nat: negative input"+{-# NOINLINE _errmsg_unsafeNat #-}+{-# NOINLINE _errmsg_subtraction #-}+{-# NOINLINE _errmsg_negate #-}+{-# NOINLINE _errmsg_fromInteger #-}+{-# NOINLINE _errmsg_succ #-}+{-# NOINLINE _errmsg_pred #-}+{-# NOINLINE _errmsg_toEnum #-}++----------------------------------------------------------------+----------------------------------------------------------- fin.

@@ -0,0 +1,210 @@+-- TODO: merge with the Posta version. And release them as a standalone package+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+----------------------------------------------------------------+--                                                    2015.12.17+-- |+-- Module      :  Data.Number.Natural+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  wren@community.haskell.org+-- Stability   :  experimental+-- Portability :  Haskell98 + CPP+--+-- A data type for natural numbers (aka non-negative integers).+----------------------------------------------------------------+module Data.Number.Natural+    ( Natural()+    , fromNatural+    , toNatural+    , unsafeNatural+    , MaxNatural(..)+    , NonNegativeRational+    , fromNonNegativeRational+    , toNonNegativeRational+    , unsafeNonNegativeRational+    ) where++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+#endif+import Data.Ratio++----------------------------------------------------------------+----------------------------------------------------------------+-- | Natural numbers, with unbounded-width à la 'Integer'. N.B.,+-- the 'Num' instance will throw errors on subtraction, negation,+-- and 'fromInteger' when the result is not a natural number.+newtype Natural = Natural Integer+    deriving (Eq, Ord)++instance Show Natural where+    show (Natural i) = show i++-- TODO: should we define our own Show instance, in order to just+-- show the Integer itself, relying on our 'fromInteger' definition+-- to preserve cut&paste-ability? If so, then we should ensure that+-- the Read instance is optional in whether the \"Natural\" is there+-- or not.++-- N.B., we cannot derive Read, since that would inject invalid numbers!+instance Read Natural where+    readsPrec d =+        readParen (d > 10) $ \s0 -> do+            ("Natural", s1) <- lex s0+            (i,         s2) <- readsPrec 11 s1+            maybe [] (\n -> [(n,s2)]) (toNatural i)+++-- | Safely convert a natural number to an integer.+fromNatural :: Natural -> Integer+fromNatural (Natural i) = i+{-# INLINE fromNatural #-}+++-- | Safely convert an integer to a natural number. Returns @Nothing@+-- if the integer is negative.+toNatural :: Integer -> Maybe Natural+toNatural x+    | x < 0     = Nothing+    | otherwise = Just (Natural x)+{-# INLINE toNatural #-}+++-- | Unsafely convert an integer to a natural number. Throws an+-- error if the integer is negative.+unsafeNatural :: Integer -> Natural+unsafeNatural x+    | x < 0     = error _errmsg_unsafeNatural+    | otherwise = Natural x+{-# INLINE unsafeNatural #-}+++instance Num Natural where+    Natural i + Natural j   = Natural (i + j)+    Natural i * Natural j   = Natural (i * j)+    Natural i - Natural j+        | i >= j    = Natural (i - j)+        | otherwise = error _errmsg_subtraction+    negate _        = error _errmsg_negate+    abs n           = n+    signum _        = Natural 1+    fromInteger i+        | i >= 0 && i >= 0 = Natural i+        | otherwise = error _errmsg_fromInteger+    {-# INLINE (+) #-}+    {-# INLINE (*) #-}+    {-# INLINE (-) #-}+    {-# INLINE negate #-}+    {-# INLINE abs #-}+    {-# INLINE signum #-}+    {-# INLINE fromInteger #-}++instance Enum Natural where+    succ (Natural i) = Natural (i+1)+    pred (Natural i)+        | i /= 0     = Natural (i-1)+        | otherwise  = error _errmsg_pred+    toEnum n+        | n >= 0     = Natural (toInteger n)+        | otherwise  = error _errmsg_toEnum+    fromEnum (Natural i) = fromEnum i++    enumFrom       (Natural i)             = map Natural (enumFrom i)+    enumFromThen   (Natural i) (Natural j) = map Natural (enumFromThen i j)+    enumFromTo     (Natural i) (Natural k) = map Natural (enumFromTo i k)+    enumFromThenTo (Natural i) (Natural j) (Natural k) =+        map Natural (enumFromThenTo i j k)+    {-# INLINE succ #-}+    {-# INLINE pred #-}+    {-# INLINE toEnum #-}+    {-# INLINE fromEnum #-}+    {-# INLINE enumFrom #-}+    {-# INLINE enumFromThen #-}+    {-# INLINE enumFromTo #-}+    {-# INLINE enumFromThenTo #-}++instance Real Natural where+    toRational (Natural i) = toRational i+    {-# INLINE toRational #-}++instance Integral Natural where+    quot    (Natural i) (Natural j) = Natural (quot i j)+    rem     (Natural i) (Natural j) = Natural (rem  i j)+    quotRem (Natural i) (Natural j) =+        case quotRem i j of+        (q,r) -> (Natural q, Natural r)+    div    = quot+    mod    = rem+    divMod = quotRem+    toInteger (Natural i) = i+    {-# INLINE quot #-}+    {-# INLINE rem #-}+    {-# INLINE div #-}+    {-# INLINE mod #-}+    {-# INLINE quotRem #-}+    {-# INLINE divMod #-}+    {-# INLINE toInteger #-}+++----------------------------------------------------------------+newtype MaxNatural = MaxNatural { unMaxNatural :: Natural }++instance Monoid MaxNatural where+    mempty                                = MaxNatural 0+    mappend (MaxNatural m) (MaxNatural n) = MaxNatural (max m n)+++----------------------------------------------------------------+-- TODO: come up with a more succinct name...+type NonNegativeRational = Ratio Natural++-- | Safely convert a non-negative rational to a rational.+fromNonNegativeRational :: NonNegativeRational -> Rational+fromNonNegativeRational x =+    fromNatural (numerator x) % fromNatural (denominator x)+    -- TODO: can we use @(:%)@ directly?+{-# INLINE fromNonNegativeRational #-}+++-- | Safely convert a rational to a non-negative rational. Returns+-- @Nothing@ if the argument is negative.+toNonNegativeRational :: Rational -> Maybe NonNegativeRational+toNonNegativeRational x = do+    n <- toNatural (numerator x)+    d <- toNatural (denominator x)+    return (n % d)+    -- TODO: can we use @(:%)@ directly?+{-# INLINE toNonNegativeRational #-}+++-- | Unsafely convert a rational to a non-negative rational. Throws+-- an error if the argument is negative.+unsafeNonNegativeRational :: Rational -> NonNegativeRational+unsafeNonNegativeRational x =+    case toNonNegativeRational x of+    Just y  -> y+    Nothing -> error _errmsg_unsafeNonNegativeRational+{-# INLINE unsafeNonNegativeRational #-}+++----------------------------------------------------------------+_errmsg_unsafeNatural, _errmsg_subtraction, _errmsg_negate, _errmsg_fromInteger, _errmsg_pred, _errmsg_toEnum, _errmsg_unsafeNonNegativeRational+    :: String+_errmsg_unsafeNatural = "unsafeNatural: negative input"+_errmsg_subtraction   = "(-)@Natural: Num is a bad abstraction"+_errmsg_negate        = "negate@Natural: Num is a bad abstraction"+_errmsg_fromInteger   = "fromInteger@Natural: Num is a bad abstraction"+_errmsg_pred          = "pred@Natural: No predecessor of zero"+_errmsg_toEnum        = "toEnum@Natural: negative input"+_errmsg_unsafeNonNegativeRational = "unsafeNonNegativeRational: negative input"+{-# NOINLINE _errmsg_unsafeNatural #-}+{-# NOINLINE _errmsg_subtraction #-}+{-# NOINLINE _errmsg_negate #-}+{-# NOINLINE _errmsg_fromInteger #-}+{-# NOINLINE _errmsg_pred #-}+{-# NOINLINE _errmsg_toEnum #-}+{-# NOINLINE _errmsg_unsafeNonNegativeRational #-}++----------------------------------------------------------------+----------------------------------------------------------- fin.

@@ -0,0 +1,388 @@+--------------------------------------------------------------------------------+--                                                                 2016.09.08+-- |+-- Module      :  Language.Hakaru.CodeGen.AST+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  zsulliva@indiana.edu+-- Stability   :  experimental+-- Portability :  GHC-only+--+--   An AST for the C Family and preprocessor+-- Much of this is based on Manuel M T Chakravarty and Benedikt+-- Hubar's "language-c" package+--+--------------------------------------------------------------------------------++module Language.Hakaru.CodeGen.AST+  ( Preprocessor(..), Ident(..), CAST(..), CExtDecl(..), CFunDef(..)++  -- declaration constructors+  , CDecl(..), CDeclr(..), CDeclSpec(..), CStorageSpec(..), CTypeQual(..)+  , CDirectDeclr(..), CTypeSpec(..), CSUSpec(..), CSUTag(..), CEnum(..)+  , CInit(..), CPartDesig(..), CFunSpec(..), CPtrDeclr(..)++  -- statements and expression constructors+  , CStat(..), CCompoundBlockItem(..), CExpr(..), CConst(..), CUnaryOp(..)+  , CBinaryOp(..), CAssignOp(..)++  -- infix and smart constructors+  , (.>.),(.<.),(.==.),(.||.),(.&&.),(.*.),(./.),(.-.),(.+.),(.=.),(.+=.),(.*=.)+  , (.>=.),(.<=.)+  , seqCStat+  , indirect, address, intE, floatE, stringE, mkUnary+  , exp, expm1, log, log1p, sqrt, rand, infinityE, negInfinityE, printfE+  ) where++import Prelude hiding (exp,log,sqrt)+++--------------------------------------------------------------------------------+--                               Top Level                                    --+--------------------------------------------------------------------------------++data CAST+  = CAST [CExtDecl]+  deriving (Show, Eq, Ord)+++data CExtDecl+  = CDeclExt    CDecl+  | CFunDefExt  CFunDef+  | CCommentExt String+  | CPPExt      Preprocessor+  deriving (Show, Eq, Ord)++data CFunDef+  = CFunDef [CDeclSpec] CDeclr [CDecl] CStat+  deriving (Show, Eq, Ord)++{-+  This is currently a very rough AST for preprocessor. Preprocessor macros+  can be inserted at the top level and at the statement level+-}+data Preprocessor+  = PPDefine  String String+  | PPInclude String+  | PPUndef   String+  | PPIf      String+  | PPIfDef   String+  | PPIfNDef  String+  | PPElse    String+  | PPElif    String+  | PPEndif   String+  | PPError   String+  | PPPragma  [String]+  deriving (Show, Eq, Ord)++data Ident+ = Ident String+ deriving (Show, Eq, Ord)+++--------------------------------------------------------------------------------+--                               C Declarations                               --+--------------------------------------------------------------------------------+{-+  C Declarations provide tools for laying out memory objections.+-}++data CDecl+  = CDecl [CDeclSpec] [(CDeclr, Maybe CInit)]+  deriving (Show, Eq, Ord)++----------------+-- Specifiers --+----------------++-- top level specifier+data CDeclSpec+  = CStorageSpec CStorageSpec+  | CTypeSpec    CTypeSpec+  | CTypeQual    CTypeQual+  | CFunSpec     CFunSpec+  deriving (Show, Eq, Ord)++data CStorageSpec+  = CTypeDef+  | CExtern+  | CStatic+  | CAuto+  | CRegister+  deriving (Show, Eq, Ord)++data CTypeQual+  = CConstQual+  | CVolatQual+  deriving (Show, Eq, Ord)++data CFunSpec = Inline+  deriving (Show, Eq, Ord)++data CTypeSpec+  = CVoid+  | CChar+  | CShort+  | CInt+  | CLong+  | CFloat+  | CDouble+  | CSigned+  | CUnsigned+  | CSUType      CSUSpec+  | CTypeDefType Ident+  | CEnumType    CEnum+  deriving (Show, Eq, Ord)++data CSUSpec+  = CSUSpec CSUTag (Maybe Ident) [CDecl]+  deriving (Show, Eq, Ord)++data CSUTag+  = CStructTag+  | CUnionTag+  deriving (Show, Eq, Ord)++data CEnum+  = CEnum (Maybe Ident) [(Ident, Maybe CExpr)]+  deriving (Show, Eq, Ord)++-----------------+-- Declarators --+-----------------+{-+  Declarators give us labels to point at and describe the level of indirection.+  between a label and the underlieing memory+-}++data CDeclr+  = CDeclr (Maybe CPtrDeclr) [CDirectDeclr]+  deriving (Show, Eq, Ord)++data CPtrDeclr = CPtrDeclr [CTypeQual]+  deriving (Show, Eq, Ord)++-- this is incomplete+data CDirectDeclr+  = CDDeclrIdent Ident+  | CDDeclrArr   CDirectDeclr CExpr+  | CDDeclrFun   CDirectDeclr [CTypeSpec]+  deriving (Show, Eq, Ord)++------------------+-- Initializers --+------------------+{-+  Initializers allow us to fill our objects with values right as they are+  declared rather than as a side-effect later in the program.+-}++data CInit+  = CInitExpr CExpr+  | CInitList [([CPartDesig], CInit)]+  deriving (Show, Eq, Ord)++data CPartDesig+  = CArrDesig    CExpr+  | CMemberDesig CExpr+  deriving (Show, Eq, Ord)++--------------------------------------------------------------------------------+--                                C Statments                                 --+--------------------------------------------------------------------------------+{-+  The separation between C Statements and C Expressions is fuzzy. Here we take+  statements as side-effecting operations sequenced by the ";" in pedantic C+  concrete syntax. Though operators like "++" that are represented as C+  Expressions in this AST also perform side-effects.+-}++data CStat+  = CLabel    Ident CStat+  | CGoto     Ident+  | CSwitch   CExpr CStat+  | CCase     CExpr CStat+  | CDefault  CStat+  | CExpr     (Maybe CExpr)+  | CCompound [CCompoundBlockItem]+  | CIf       CExpr CStat (Maybe CStat)+  | CWhile    CExpr CStat Bool+  | CFor      (Maybe CExpr) (Maybe CExpr) (Maybe CExpr) CStat+  | CCont+  | CBreak+  | CReturn   (Maybe CExpr)+  | CComment  String+  | CPPStat   Preprocessor+  deriving (Show, Eq, Ord)++data CCompoundBlockItem+  = CBlockStat CStat+  | CBlockDecl CDecl+  deriving (Show, Eq, Ord)++--------------------------------------------------------------------------------+--                                C Expressions                               --+--------------------------------------------------------------------------------+{-+  See C Statments...+-}++data CExpr+  = CComma       [CExpr]+  | CAssign      CAssignOp CExpr CExpr+  | CCond        CExpr CExpr CExpr+  | CBinary      CBinaryOp CExpr CExpr+  | CCast        CDecl CExpr+  | CUnary       CUnaryOp CExpr+  | CSizeOfExpr  CExpr+  | CSizeOfType  CDecl+  | CIndex       CExpr CExpr+  | CCall        CExpr [CExpr]+  | CMember      CExpr Ident Bool+  | CVar         Ident+  | CConstant    CConst+  | CCompoundLit CDecl CInit+  deriving (Show, Eq, Ord)+++data CAssignOp+  = CAssignOp+  | CMulAssOp+  | CDivAssOp+  | CRmdAssOp+  | CAddAssOp+  | CSubAssOp+  | CShlAssOp+  | CShrAssOp+  | CAndAssOp+  | CXorAssOp+  | COrAssOp+  deriving (Show, Eq, Ord)+++data CBinaryOp+  = CMulOp+  | CDivOp+  | CRmdOp+  | CAddOp+  | CSubOp+  | CShlOp+  | CShrOp+  | CLeOp+  | CGrOp+  | CLeqOp+  | CGeqOp+  | CEqOp+  | CNeqOp+  | CAndOp+  | CXorOp+  | COrOp+  | CLndOp+  | CLorOp+  deriving (Show, Eq, Ord)+++data CUnaryOp+  = CPreIncOp+  | CPreDecOp+  | CPostIncOp+  | CPostDecOp+  | CAdrOp+  | CIndOp+  | CPlusOp+  | CMinOp+  | CCompOp+  | CNegOp+  deriving (Show, Eq, Ord)+++data CConst+  = CIntConst    Integer+  | CCharConst   Char+  | CFloatConst  Float+  | CStringConst String+  deriving (Show, Eq, Ord)+++--------------------------------------------------------------------------------+--                      Infix and Smart Constructors                          --+--------------------------------------------------------------------------------+{-+  These are helpful when building up ASTs in Haskell code. They correspond to+  the concrete syntax of C. This is an incomplete set...+-}++seqCStat :: [CStat] -> CStat+seqCStat = CCompound . fmap CBlockStat++(.<.),(.>.),(.==.),(.||.),(.&&.),(.*.),(./.),(.-.),(.+.),(.=.),(.+=.),(.*=.),(.<=.),(.>=.)+  :: CExpr -> CExpr -> CExpr+a .<. b  = CBinary CLeOp a b+a .>. b  = CBinary CGrOp a b+a .==. b = CBinary CEqOp a b+a .||. b = CBinary CLorOp a b+a .&&. b = CBinary CAndOp a b+a .*. b  = CBinary CMulOp a b+a ./. b  = CBinary CDivOp a b+a .-. b  = CBinary CSubOp a b+a .+. b  = CBinary CAddOp a b+a .<=. b = CBinary CLeqOp a b+a .>=. b = CBinary CGeqOp a b+a .=. b  = CAssign CAssignOp a b+a .+=. b = CAssign CAddAssOp a b+a .*=. b = CAssign CMulAssOp a b++indirect, address :: CExpr -> CExpr+indirect = CUnary CIndOp+address  = CUnary CAdrOp++intE :: Integer -> CExpr+intE = CConstant . CIntConst++floatE :: Float -> CExpr+floatE = CConstant . CFloatConst++stringE :: String -> CExpr+stringE = CConstant . CStringConst++mkUnary :: String -> CExpr -> CExpr+mkUnary s = CCall (CVar . Ident $ s) . (:[])++--------------------------------------------------------------------------------+--                                 Lib C                                      --+--------------------------------------------------------------------------------+{-+  Here we have calls to a very small subset of functionality provided by libc.+  In the future, we should have a standard way to add in bindings to C+  libraries. Easily generating code for existing C libraries is one of the key+  design goals of pedantic-c+-}++------------+-- math.h --+------------++exp,expm1,log,log1p,sqrt :: CExpr -> CExpr+exp   = mkUnary "exp"+expm1 = mkUnary "expm1"+log   = mkUnary "log"+log1p = mkUnary "log1p"+sqrt  = mkUnary "sqrt"++infinityE,negInfinityE :: CExpr+infinityE    = (intE 1) ./. (intE 0)+negInfinityE = log (intE 0)++--------------+-- stdlib.h --+--------------++rand :: CExpr+rand = CCall (CVar . Ident $ "rand") []++--------------+-- stdlio.h --+--------------++printfE :: [CExpr] -> CExpr+printfE = CCall (CVar . Ident $ "printf")

@@ -0,0 +1,364 @@+{-# LANGUAGE CPP,+             BangPatterns,+             DataKinds,+             FlexibleContexts,+             FlexibleInstances,+             GADTs,+             KindSignatures,+             PolyKinds,+             StandaloneDeriving,+             TypeOperators,+             RankNTypes        #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++----------------------------------------------------------------+--                                                    2016.07.01+-- |+-- Module      :  Language.Hakaru.CodeGen.CodeGenMonad+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  zsulliva@indiana.edu+-- Stability   :  experimental+-- Portability :  GHC-only+--+--   This module provides a monad for C code generation as well+-- as some useful helper functions for manipulating it+----------------------------------------------------------------+++module Language.Hakaru.CodeGen.CodeGenMonad+  ( CodeGen+  , CG(..)+  , runCodeGen+  , runCodeGenBlock+  , runCodeGenWith+  , emptyCG+  , suffixes++  -- codegen effects+  , declare+  , declare'+  , assign+  , putStat+  , putExprStat+  , extDeclare+  , defineFunction+  , funCG+  , isParallel+  , mkParallel+  , mkSequential++  , reserveName+  , genIdent+  , genIdent'++  -- Hakaru specific+  , createIdent+  , lookupIdent++  -- control mechanisms+  , whileCG+  , doWhileCG+  , forCG+  , reductionCG+  ) where++import Control.Monad.State.Strict++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+import Control.Applicative ((<$>))+#endif++import Language.Hakaru.Syntax.ABT hiding (var)+import Language.Hakaru.Types.DataKind+import Language.Hakaru.Types.Sing+import Language.Hakaru.CodeGen.Types+import Language.Hakaru.CodeGen.AST+import Language.Hakaru.CodeGen.Pretty++import Data.Number.Nat (fromNat)+import qualified Data.IntMap.Strict as IM+import qualified Data.Text          as T+import qualified Data.Set           as S++import Text.PrettyPrint (render)++suffixes :: [String]+suffixes = filter (\n -> not $ elem (head n) ['0'..'9']) names+  where base :: [Char]+        base = ['0'..'9'] ++ ['a'..'z']+        names = [[x] | x <- base] `mplus` (do n <- names+                                              [n++[x] | x <- base])++-- CG after "codegen", holds the state of a codegen computation+data CG = CG { freshNames    :: [String]     -- ^ fresh names for code generations+             , reservedNames :: S.Set String -- ^ reserve names during code generations+             , extDecls      :: [CExtDecl]   -- ^ total external declarations+             , declarations  :: [CDecl]      -- ^ declarations in local block+             , statements    :: [CStat]      -- ^ statements can include assignments as well as other side-effects+             , varEnv        :: Env          -- ^ mapping between Hakaru vars and codegeneration vars+             , parallel      :: Bool         -- ^ openMP supported block+             }++emptyCG :: CG+emptyCG = CG suffixes mempty mempty [] [] emptyEnv False++type CodeGen = State CG++runCodeGen :: CodeGen a -> ([CExtDecl],[CDecl], [CStat])+runCodeGen m =+  let (_, cg) = runState m emptyCG+  in  ( reverse $ extDecls     cg+      , reverse $ declarations cg+      , reverse $ statements   cg )+++runCodeGenBlock :: CodeGen a -> CodeGen CStat+runCodeGenBlock m =+  do cg <- get+     let (_,cg') = runState m $ cg { statements = []+                                   , declarations = [] }+     put $ cg' { statements   = statements cg+               , declarations = declarations cg' ++ declarations cg+               }+     return . CCompound . fmap CBlockStat . reverse . statements $ cg'++runCodeGenWith :: CodeGen a -> CG -> [CExtDecl]+runCodeGenWith cg start = let (_,cg') = runState cg start in reverse $ extDecls cg'++--------------------------------------------------------------------------------++isParallel :: CodeGen Bool+isParallel = parallel <$> get++mkParallel :: CodeGen ()+mkParallel =+  do cg <- get+     put (cg { parallel = True } )++mkSequential :: CodeGen ()+mkSequential =+  do cg <- get+     put (cg { parallel = False } )++--------------------------------------------------------------------------------++reserveName :: String -> CodeGen ()+reserveName s =+  get >>= \cg -> put $ cg { reservedNames = s `S.insert` reservedNames cg }+++genIdent :: CodeGen Ident+genIdent =+  do cg <- get+     let (freshNs,name) = pullName (freshNames cg) (reservedNames cg)+     put $ cg { freshNames = freshNs }+     return $ Ident name+  where pullName :: [String] -> S.Set String -> ([String],String)+        pullName (n:names) reserved =+          let name = "_" ++ n in+          if S.member name reserved+          then let (names',out) = pullName names reserved+               in  (n:names',out)+          else (names,name)+        pullName _ _ = error "should not happen, names is infinite"++genIdent' :: String -> CodeGen Ident+genIdent' s =+  do cg <- get+     let (freshNs,name) = pullName (freshNames cg) (reservedNames cg)+     put $ cg { freshNames = freshNs }+     return $ Ident name+  where pullName :: [String] -> S.Set String -> ([String],String)+        pullName (n:names) reserved =+          let name = s ++ "_" ++ n in+          if S.member name reserved+          then let (names',out) = pullName names reserved+               in  (n:names',out)+          else (names,name)+        pullName _ _ = error "should not happen, names is infinite"++++createIdent :: Variable (a :: Hakaru) -> CodeGen Ident+createIdent var@(Variable name _ _) =+  do !cg <- get+     let ident = Ident $ (T.unpack name) ++ "_" ++ (head $ freshNames cg)+         env'  = updateEnv var ident (varEnv cg)+     put $! cg { freshNames = tail $ freshNames cg+               , varEnv     = env' }+     return ident++lookupIdent :: Variable (a :: Hakaru) -> CodeGen Ident+lookupIdent var =+  do !cg <- get+     let !env = varEnv cg+     case lookupVar var env of+       Nothing -> error $ "lookupIdent: var not found --" ++ show var+       Just i  -> return i++-- | types like SData and SMeasure are impure in that they will produce extra+--   code in the CodeGenMonad while literal types SReal, SInt, SNat, and SProb+--   do not+declare :: Sing (a :: Hakaru) -> Ident -> CodeGen ()+declare SInt          = declare' . typeDeclaration SInt+declare SNat          = declare' . typeDeclaration SNat+declare SProb         = declare' . typeDeclaration SProb+declare SReal         = declare' . typeDeclaration SReal+declare (SMeasure (SArray t))  = \i -> do extDeclare $ arrayStruct t+                                          extDeclare $ mdataStruct t+                                          declare'   $ mdataDeclaration (SArray t) i+declare (SMeasure t)  = \i -> do extDeclare $ mdataStruct t+                                 declare'   $ mdataDeclaration t i+declare (SArray t)    = \i -> do extDeclare $ arrayStruct t+                                 declare'   $ arrayDeclaration t i+declare d@(SData _ _) = \i -> do extDeclare $ datumStruct d+                                 declare'   $ datumDeclaration d i+declare (SFun _ _)    = \_ -> return () -- function definitions handeled in flatten+++declare' :: CDecl -> CodeGen ()+declare' d = do cg <- get+                put $ cg { declarations = d:(declarations cg) }++putStat :: CStat -> CodeGen ()+putStat s = do cg <- get+               put $ cg { statements = s:(statements cg) }++putExprStat :: CExpr -> CodeGen ()+putExprStat = putStat . CExpr . Just++assign :: Ident -> CExpr -> CodeGen ()+assign ident e = putStat . CExpr . Just $ (CVar ident .=. e)+++extDeclare :: CExtDecl -> CodeGen ()+extDeclare d = do cg <- get+                  let extds = extDecls cg+                      extds' = if elem d extds+                               then extds+                               else d:extds+                  put $ cg { extDecls = extds' }++defineFunction :: Sing (a :: Hakaru) -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()+defineFunction typ ident args mbody =+  do cg <- get+     mbody+     !cg' <- get+     let decls = reverse . declarations $ cg'+         stmts = reverse . statements   $ cg'+         def :: Sing (a :: Hakaru) -> CFunDef+         def SInt         = functionDef SInt  ident args decls stmts+         def SNat         = functionDef SNat  ident args decls stmts+         def SProb        = functionDef SProb ident args decls stmts+         def SReal        = functionDef SReal ident args decls stmts+         def (SMeasure t) = functionDef (SMeasure t) ident args decls stmts+         def t            = error $ "TODO: defined function of type: " ++ show t++     -- reset local statements and declarations+     put $ cg' { statements   = statements cg+               , declarations = declarations cg }+     extDeclare . CFunDefExt $ def typ++funCG :: CTypeSpec -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()+funCG ts ident args mbody =+  do cg <- get+     mbody+     !cg' <- get+     let decls = reverse . declarations $ cg'+         stmts = reverse . statements   $ cg'+     -- reset local statements and declarations+     put $ cg' { statements   = statements cg+               , declarations = declarations cg }+     extDeclare . CFunDefExt $+       CFunDef [CTypeSpec ts]+               (CDeclr Nothing [ CDDeclrIdent ident ])+               args+               (CCompound ((fmap CBlockDecl decls) ++ (fmap CBlockStat stmts)))+++++---------+-- ENV --+---------++newtype Env = Env (IM.IntMap Ident)+  deriving Show++emptyEnv :: Env+emptyEnv = Env IM.empty++updateEnv :: Variable (a :: Hakaru) -> Ident -> Env -> Env+updateEnv (Variable _ nat _) ident (Env env) =+  Env $! IM.insert (fromNat nat) ident env++lookupVar :: Variable (a :: Hakaru) -> Env -> Maybe Ident+lookupVar (Variable _ nat _) (Env env) =+  IM.lookup (fromNat nat) env++----------------------------------------------------------------+-- Control Flow++whileCG :: CExpr -> CodeGen () -> CodeGen ()+whileCG bE m =+  let (_,_,stmts) = runCodeGen m+  in putStat $ CWhile bE (CCompound $ fmap CBlockStat stmts) False++doWhileCG :: CExpr -> CodeGen () -> CodeGen ()+doWhileCG bE m =+  let (_,_,stmts) = runCodeGen m+  in putStat $ CWhile bE (CCompound $ fmap CBlockStat stmts) True++-- forCG and reductionCG both create C for loops, their difference lies in the+-- parallel code they generate++forCG+  :: CExpr+  -> CExpr+  -> CExpr+  -> CodeGen ()+  -> CodeGen ()+forCG iter cond inc body =+  do cg <- get+     let (_,cg') = runState body $ cg { statements = []+                                      , declarations = [] }+     put $ cg' { statements = statements cg+               , declarations = declarations cg }+     par <- isParallel+     when par . putStat . CPPStat . PPPragma+       $ ["omp","parallel","for"]+     putStat $ CFor (Just iter)+                    (Just cond)+                    (Just inc)+                    (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')+                               ++ (fmap CBlockStat (reverse $ statements cg'))))++reductionCG+  :: CBinaryOp+  -> Ident+  -> CExpr+  -> CExpr+  -> CExpr+  -> CodeGen ()+  -> CodeGen ()+reductionCG op acc iter cond inc body =+  do cg <- get+     let (_,cg') = runState body $ cg { statements = []+                                      , declarations = [] }+     put $ cg' { statements = statements cg+               , declarations = declarations cg }+     par <- isParallel+     when par . putStat . CPPStat . PPPragma+       $ ["omp","parallel","for"+         , concat ["reduction("+                  ,render . pretty $ op+                  ,":"+                  ,render . pretty $ acc+                  ,")"]]+     putStat $ CFor (Just iter)+                    (Just cond)+                    (Just inc)+                    (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')+                               ++ (fmap CBlockStat (reverse $ statements cg'))))

@@ -0,0 +1,1244 @@+{-# LANGUAGE CPP,+             BangPatterns,+             DataKinds,+             FlexibleContexts,+             GADTs,+             KindSignatures,+             ScopedTypeVariables,+             RankNTypes,+             TypeOperators #-}++----------------------------------------------------------------+--                                                    2016.06.23+-- |+-- Module      :  Language.Hakaru.CodeGen.Flatten+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  zsulliva@indiana.edu+-- Stability   :  experimental+-- Portability :  GHC-only+--+--   Flatten takes Hakaru ABTs and C vars and returns a CStatement+-- assigning the var to the flattened ABT.+--+----------------------------------------------------------------+++module Language.Hakaru.CodeGen.Flatten+  ( flattenABT+  , flattenVar+  , flattenTerm )+  where++import Language.Hakaru.CodeGen.CodeGenMonad+import Language.Hakaru.CodeGen.AST+import Language.Hakaru.CodeGen.Types++import Language.Hakaru.Syntax.AST+import Language.Hakaru.Syntax.ABT+import Language.Hakaru.Syntax.TypeOf (typeOf)+import Language.Hakaru.Syntax.Datum hiding (Ident)+import qualified Language.Hakaru.Syntax.Prelude as HKP+import Language.Hakaru.Types.DataKind+import Language.Hakaru.Types.HClasses+import Language.Hakaru.Types.Coercion+import Language.Hakaru.Types.Sing++import           Control.Monad.State.Strict+import           Control.Monad (replicateM)+import           Data.Number.Natural+import           Data.Ratio+import qualified Data.List.NonEmpty as NE+import qualified Data.Sequence      as S+import qualified Data.Foldable      as F+import qualified Data.Traversable   as T+++#if __GLASGOW_HASKELL__ < 710+import           Data.Functor+#endif++import Prelude hiding (log,exp,sqrt)+++opComment :: String -> CStat+opComment opStr = CComment $ concat [space," ",opStr," ",space]+  where size  = (50 - (length opStr)) `div` 2 - 8+        space = replicate size '-'++--------------------------------------------------------------------------------+--                                 Top Level                                  --+--------------------------------------------------------------------------------+{-++flattening an ABT will produce a continuation that takes a CExpr representing+a location where the value of the ABT should be stored. Return type of the+the continuation is CodeGen Bool, where the computed bool is whether or not+there is a Reject inside the ABT. Therefore it is only needed when computing+mochastic values++-}++flattenABT+  :: ABT Term abt+  => abt '[] a+  -> (CExpr -> CodeGen ())+flattenABT abt = caseVarSyn abt flattenVar flattenTerm++-- note that variables will find their values in the state of the CodeGen monad+flattenVar+  :: Variable (a :: Hakaru)+  -> (CExpr -> CodeGen ())+flattenVar v = \loc ->+  do v' <- CVar <$> lookupIdent v+     putStat . CExpr . Just $ loc .=. v'++flattenTerm+  :: ABT Term abt+  => Term abt a+  -> (CExpr -> CodeGen ())+flattenTerm (NaryOp_ t s)    = flattenNAryOp t s+flattenTerm (Literal_ x)     = flattenLit x+flattenTerm (Empty_ _)       = error "TODO: flattenTerm Empty"++flattenTerm (Datum_ d)       = flattenDatum d+flattenTerm (Case_ c bs)     = flattenCase c bs++flattenTerm (Array_ s e)     = flattenArray s e++-- SCon can contain mochastic terms+flattenTerm (x :$ ys)        = flattenSCon x ys++---------------------+-- Mochastic Terms --+---------------------+flattenTerm (Reject_ _)      = \loc -> putExprStat (mdataPtrWeight loc .=. (intE 0)) -- fail to draw a sample+flattenTerm (Superpose_ wes) = flattenSuperpose wes++++++--------------------------------------------------------------------------------+--                                  SCon                                      --+--------------------------------------------------------------------------------++flattenSCon+  :: ( ABT Term abt )+  => SCon args a+  -> SArgs abt args+  -> (CExpr -> CodeGen ())++flattenSCon Let_ =+  \(expr :* body :* End) ->+    \loc -> do+      caseBind body $ \v@(Variable _ _ typ) body'->+        do ident <- createIdent v+           declare typ ident+           flattenABT expr (CVar ident)+           flattenABT body' loc++-- Lambdas produce functions and then return a function pointer+flattenSCon Lam_ = undefined+  -- \(body :* End) ->+  --   \loc ->+  --     do coalesceLambda body $ \vars body' ->+  --        let varMs = foldMap11 (\v -> [mkVarDecl v =<< createIdent v]) vars+  --        in  do funcId <- genIdent' "fn"+  --               argDecls <- sequence varMs++  --               cg <- get+  --               let m       = putStat . CReturn . Just =<< flattenABT body'+  --                   (_,cg') = runState m $ cg { statements = []+  --                                             , declarations = [] }+  --               put $ cg' { statements   = statements cg+  --                         , declarations = declarations cg }++  --               extDeclare . CFunDefExt $ functionDef (typeOf body')+  --                                                     funcId+  --                                                     argDecls+  --                                                     (reverse $ declarations cg')+  --                                                     (reverse $ statements cg')+  -- -- do at top level+  -- where coalesceLambda+  --         :: ( ABT Term abt )+  --         => abt '[x] a+  --         -> (forall (ys :: [Hakaru]) b. List1 Variable ys -> abt '[] b -> r)+  --         -> r+  --       coalesceLambda abt k =+  --         caseBind abt $ \v abt' ->+  --           caseVarSyn abt' (const (k (Cons1 v Nil1) abt')) $ \term ->+  --             case term of+  --               (Lam_ :$ body :* End) ->+  --                 coalesceLambda body $ \vars abt'' -> k (Cons1 v vars) abt''+  --               _ -> k (Cons1 v Nil1) abt'++  --       mkVarDecl :: Variable (a :: Hakaru) -> Ident -> CodeGen CDecl+  --       mkVarDecl (Variable _ _ SInt)  = return . typeDeclaration SInt+  --       mkVarDecl (Variable _ _ SNat)  = return . typeDeclaration SNat+  --       mkVarDecl (Variable _ _ SProb) = return . typeDeclaration SProb+  --       mkVarDecl (Variable _ _ SReal) = return . typeDeclaration SReal+  --       mkVarDecl (Variable _ _ (SArray t)) = \i -> do extDeclare $ arrayStruct t+  --                                                      return $ arrayDeclaration t i+  --       mkVarDecl (Variable _ _ d@(SData _ _)) = \i -> do extDeclare $ datumStruct d+  --                                                         return $ datumDeclaration d i+  --       mkVarDecl v = error $ "flattenSCon.Lam_.mkVarDecl cannot handle vars of type " ++ show v+++flattenSCon (PrimOp_ op) = flattenPrimOp op++flattenSCon (ArrayOp_ op) = flattenArrayOp op++flattenSCon (Summate _ sr) =+  \(lo :* hi :* body :* End) ->+    \loc ->+      caseBind body $ \v body' ->+        do loId <- genIdent+           hiId <- genIdent+           declare (typeOf lo) loId+           declare (typeOf hi) hiId+           let loE = CVar loId+               hiE = CVar hiId+           flattenABT lo loE+           flattenABT hi hiE++           iterI <- createIdent v+           declare SNat iterI++           accI <- genIdent' "acc"+           let semiT = sing_HSemiring sr+           declare semiT accI+           assign accI (case semiT of+                          SProb -> negInfinityE+                          SReal -> floatE 0+                          _     -> intE 0)++           let accVar  = CVar accI+               iterVar = CVar iterI+++           putStat $ opComment "Summate"+           -- logSumExp for probabilities+           reductionCG CAddOp+                       accI+                       (iterVar .=. loE)+                       (iterVar .<. hiE)+                       (CUnary CPostIncOp iterVar) $+             do tmpId <- genIdent+                declare (typeOf body') tmpId+                let tmpE = CVar tmpId+                flattenABT body' tmpE+                case semiT of+                  SProb -> logSumExpCG (S.fromList [accVar,tmpE]) accVar+                  _     -> putStat . CExpr . Just $ (accVar .+=. tmpE)++           putExprStat (loc .=. accVar)+++flattenSCon (Product _ sr) =+  \(lo :* hi :* body :* End) ->+    \loc ->+      caseBind body $ \v body' ->+        do loId <- genIdent+           hiId <- genIdent+           declare (typeOf lo) loId+           declare (typeOf hi) hiId+           let loE = CVar loId+               hiE = CVar hiId+           flattenABT lo loE+           flattenABT hi hiE++           iterI <- createIdent v+           declare SNat iterI++           accI <- genIdent' "acc"+           let semiT = sing_HSemiring sr+           declare semiT accI+           assign accI (case semiT of+                          SProb -> floatE 0+                          SReal -> floatE 1+                          _     -> intE 1)++           let accVar  = CVar accI+               iterVar = CVar iterI++           putStat $ opComment "Product"+           reductionCG (case semiT of+                          SProb -> CAddOp+                          _     -> CMulOp)+                       accI+                       (iterVar .=. loE)+                       (iterVar .<. hiE)+                       (CUnary CPostIncOp iterVar) $+             do tmpId <- genIdent+                declare (typeOf body') tmpId+                let tmpE = CVar tmpId+                flattenABT body' tmpE+                putExprStat $ case semiT of+                                SProb -> CAssign CAddAssOp accVar+                                _ -> CAssign CMulAssOp accVar+                            $ tmpE++           putExprStat (loc .=. accVar)+++--------------------+-- SCon Coersions --+--------------------++-- at this point, only nonrecusive coersions are implemented+flattenSCon (CoerceTo_ ctyp) =+  \(e :* End) ->+    \loc ->+       do eId <- genIdent+          let eT = typeOf e+              eE = CVar eId+          declare eT eId+          flattenABT e eE+          putExprStat . (CAssign CAssignOp loc) =<< coerceToType ctyp eT eE+  where coerceToType+          :: Coercion a b+          -> Sing (c :: Hakaru)+          -> CExpr+          -> CodeGen CExpr+        coerceToType (CCons p rest) typ =+          \e ->  primitiveCoerce p typ e >>= coerceToType rest typ+        coerceToType CNil            _  = return . id++        primitiveCoerce+          :: PrimCoercion a b+          -> Sing (c :: Hakaru)+          -> CExpr+          -> CodeGen CExpr+        primitiveCoerce (Signed HRing_Int)            SNat  = nat2int+        primitiveCoerce (Signed HRing_Real)           SProb = prob2real+        primitiveCoerce (Continuous HContinuous_Prob) SNat  = nat2prob+        primitiveCoerce (Continuous HContinuous_Real) SInt  = int2real+        primitiveCoerce (Continuous HContinuous_Real) SNat  = int2real+        primitiveCoerce a b = error $ "flattenSCon CoerceTo_: cannot preform coersion "+                                    ++ show a+                                    ++ " to "+                                    ++ show b+++        -- implementing ONLY functions found in Hakaru.Syntax.AST+        nat2int,nat2prob,prob2real,int2real+          :: CExpr -> CodeGen CExpr+        nat2int   = return+        nat2prob  = \n -> do ident <- genIdent' "p"+                             declare SProb ident+                             assign ident . log1p $ n .-. (intE 1)+                             return (CVar ident)+        prob2real = \p -> do ident <- genIdent' "r"+                             declare SReal ident+                             assign ident $ (expm1 p) .+. (intE 1)+                             return (CVar ident)+        int2real  = return . CCast doubleDecl+++-----------------------------------+-- SCons in the Stochastic Monad --+-----------------------------------++flattenSCon (MeasureOp_ op) = flattenMeasureOp op++flattenSCon Dirac           =+  \(e :* End) ->+    \loc ->+       do sId <- genIdent' "samp"+          declare (typeOf e) sId+          let sE = CVar sId+          flattenABT e sE+          putExprStat $ mdataPtrWeight loc .=. (floatE 0)+          putExprStat $ mdataPtrSample loc .=. sE++flattenSCon MBind           =+  \(ma :* b :* End) ->+    \loc ->+      caseBind b $ \v@(Variable _ _ typ) mb ->+        do -- first+           mId <- genIdent' "m"+           declare (typeOf ma) mId+           let mE = CVar mId+           flattenABT ma (address mE)++           -- assign that sample to var+           vId <- createIdent v+           declare typ vId+           assign vId (mdataSample mE)+           flattenABT mb loc+           putExprStat $ mdataPtrWeight loc .+=. (mdataWeight mE)++-- for now plats make use of a global sample+flattenSCon Plate           =+  \(size :* b :* End) ->+    \loc ->+      caseBind b $ \v@(Variable _ _ typ) body ->+        do sizeId <- genIdent' "s"+           declare SNat sizeId+           let sizeE = CVar sizeId+           flattenABT size sizeE+           putExprStat $   (arrayPtrData . mdataPtrSample $ loc)+                       .=. (CCast (mkPtrDecl . buildType $ typ)+                                  (mkUnary "malloc"+                                  (sizeE .*. (CSizeOfType . mkDecl . buildType $ typ))))++++           weightId <- genIdent' "w"+           declare SProb weightId+           let weightE = CVar weightId+           assign weightId (floatE 0)++           itId <- createIdent v+           declare SNat itId+           let itE = CVar itId+               currInd  = indirect $ (CMember (mdataSample loc) (Ident "data") True) .+. itE++           sampId <- genIdent' "samp"+           declare (typeOf $ body) sampId+           let sampE = CVar sampId++           reductionCG CAddOp+                       weightId+                       (itE .=. (intE 0))+                       (itE .<. sizeE)+                       (CUnary CPostIncOp itE)+                       (do flattenABT body (address sampE)+                           putExprStat (currInd .=. (mdataSample sampE))+                           putExprStat (weightE .+=. (mdataWeight sampE)))++           putExprStat $ mdataPtrWeight loc .=. weightE+++-----------------------------------+-- SCon's that arent implemented --+-----------------------------------++flattenSCon x               = \_ -> \_ -> error $ "TODO: flattenSCon: " ++ show x++++++--------------------------------------------------------------------------------+--                                 NaryOps                                    --+--------------------------------------------------------------------------------++flattenNAryOp :: ABT Term abt+              => NaryOp a+              -> S.Seq (abt '[] a)+              -> (CExpr -> CodeGen ())+flattenNAryOp op args =+  \loc ->+    do es <- T.forM args $ \a ->+               do aId <- genIdent+                  let aE = CVar aId+                  declare (typeOf a) aId+                  _ <- flattenABT a aE+                  return aE+       case op of+         And -> boolNaryOp op es loc+         Or  -> boolNaryOp op es loc+         Xor -> boolNaryOp op es loc+         Iff -> boolNaryOp op es loc++         (Sum HSemiring_Prob) -> logSumExpCG es loc++         _ -> let opE = F.foldr (binaryOp op) (S.index es 0) (S.drop 1 es)+              in  putExprStat (loc .=. opE)+++  where boolNaryOp op' es' loc' =+          let indexOf x = CMember x (Ident "index") True+              es''      = fmap indexOf es'+              expr      = F.foldr (binaryOp op')+                                  (S.index es'' 0)+                                  (S.drop 1 es'')+          in  putExprStat ((indexOf loc') .=. expr)+++--------------------------------------+-- LogSumExp for NaryOp Add [SProb] --+--------------------------------------+{-++Special for addition of probabilities we have a logSumExp. This will compute the+sum of the probabilities safely. Just adding the exp(a . prob) would make us+loose any of the safety from underflow that we got from storing prob in the log+domain++-}++-- the tree traversal is a depth first search+logSumExp :: S.Seq CExpr -> CExpr+logSumExp es = mkCompTree 0 1++  where lastIndex  = S.length es - 1++        compIndices :: Int -> Int -> CExpr -> CExpr -> CExpr+        compIndices i j = CCond ((S.index es i) .>. (S.index es j))++        mkCompTree :: Int -> Int -> CExpr+        mkCompTree i j+          | j == lastIndex = compIndices i j (logSumExp' i) (logSumExp' j)+          | otherwise      = compIndices i j+                               (mkCompTree i (succ j))+                               (mkCompTree j (succ j))++        diffExp :: Int -> Int -> CExpr+        diffExp a b = expm1 ((S.index es a) .-. (S.index es b))++        -- given the max index, produce a logSumExp expression+        logSumExp' :: Int -> CExpr+        logSumExp' 0 = S.index es 0+          .+. (log1p $ foldr (\x acc -> diffExp x 0 .+. acc)+                            (diffExp 1 0)+                            [2..S.length es - 1]+                    .+. (intE $ fromIntegral lastIndex))+        logSumExp' i = S.index es i+          .+. (log1p $ foldr (\x acc -> if i == x+                                       then acc+                                       else diffExp x i .+. acc)+                            (diffExp 0 i)+                            [1..S.length es - 1]+                    .+. (intE $ fromIntegral lastIndex))+++-- | logSumExpCG creates global functions for every n-ary logSumExp function+-- this reduces code size+logSumExpCG :: S.Seq CExpr -> (CExpr -> CodeGen ())+logSumExpCG seqE =+  let size   = S.length $ seqE+      name   = "logSumExp" ++ (show size)+      funcId = Ident name+  in \loc -> do-- reset the names so that the function is the same for each arity+       cg <- get+       put (cg { freshNames = suffixes })+       argIds <- replicateM size genIdent+       let decls = fmap (typeDeclaration SProb) argIds+           vars  = fmap CVar argIds+       extDeclare . CFunDefExt $ functionDef SProb+                                             funcId+                                             decls+                                             []+                                             [CReturn . Just $ logSumExp $ S.fromList vars ]+       cg' <- get+       put (cg' { freshNames = freshNames cg })+       putExprStat $ loc .=. (CCall (CVar funcId) (F.toList seqE))+++--------------------------------------------------------------------------------+--                                  Literals                                  --+--------------------------------------------------------------------------------++flattenLit+  :: Literal a+  -> (CExpr -> CodeGen ())+flattenLit lit =+  \loc ->+    case lit of+      (LNat x)  -> putExprStat $ loc .=. (intE $ fromIntegral x)+      (LInt x)  -> putExprStat $ loc .=. (intE x)+      (LReal x) -> putExprStat $ loc .=. (floatE $ fromRational x)+      (LProb x) -> let rat = fromNonNegativeRational x+                       x'  = (fromIntegral $ numerator rat)+                           / (fromIntegral $ denominator rat)+                       xE  = log1p (floatE x' .-. intE 1)+                   in putExprStat (loc .=. xE)++--------------------------------------------------------------------------------+--                                Array and ArrayOps                          --+--------------------------------------------------------------------------------+++flattenArray+  :: (ABT Term abt)+  => (abt '[] 'HNat)+  -> (abt '[ 'HNat ] a)+  -> (CExpr -> CodeGen ())+flattenArray arity body =+  \loc ->+    caseBind body $ \v@(Variable _ _ typ) body' ->+      let arityE = arraySize loc+          dataE  = arrayData loc in+      do flattenABT arity arityE+         putExprStat $   dataE+                     .=. (CCast (mkPtrDecl . buildType $ typ)+                                (mkUnary "malloc"+                                  (arityE .*. (CSizeOfType . mkDecl . buildType $ typ))))++         itId  <- createIdent v+         declare SNat itId+         let itE     = CVar itId+             currInd = indirect (dataE .+. itE)++         putStat $ opComment "Create Array"+         forCG (itE .=. (intE 0))+               (itE .<. arityE)+               (CUnary CPostIncOp itE)+               (flattenABT body' currInd)+++--------------+-- ArrayOps --+--------------++flattenArrayOp+  :: ( ABT Term abt+     , typs ~ UnLCs args+     , args ~ LCs typs+     )+  => ArrayOp typs a+  -> SArgs abt args+  -> (CExpr -> CodeGen ())+++flattenArrayOp (Index _)  =+  \(arr :* ind :* End) ->+    \loc ->+      do arrId <- genIdent' "arr"+         indId <- genIdent+         let arrE = CVar arrId+             indE = CVar indId+         declare (typeOf arr) arrId+         declare SNat indId+         flattenABT arr arrE+         flattenABT ind indE+         let valE = indirect ((CMember arrE (Ident "data") True) .+. indE)+         putExprStat (loc .=. valE)++flattenArrayOp (Size _)   =+  \(arr :* End) ->+    \loc ->+      do arrId <- genIdent' "arr"+         declare (typeOf arr) arrId+         let arrE = CVar arrId+         flattenABT arr arrE+         putExprStat (loc .=. (CMember arrE (Ident "size") True))++flattenArrayOp (Reduce _) = error "TODO: flattenArrayOp"+  -- \(fun :* base :* arr :* End) ->+  -- do funE  <- flattenABT fun+  --    baseE <- flattenABT base+  --    arrE  <- flattenABT arr+  --    accI  <- genIdent' "acc"+  --    iterI <- genIdent' "iter"++  --    let sizeE = CMember arrE (Ident "size") True+  --        iterE = CVar iterI+  --        accE  = CVar accI+  --        cond  = iterE .<. sizeE+  --        inc   = CUnary CPostIncOp iterE++  --    declare (typeOf base) accI+  --    declare SInt iterI+  --    assign accI baseE+  --    forCG (iterE .=. (intE 0)) cond inc $+  --      assign accI $ CCall funE [accE]++  --    return accE+++--------------------------------------------------------------------------------+--                                 Datum and Case                             --+--------------------------------------------------------------------------------+{-++Datum are sums of products of types. This maps to a C structure. flattenDatum+will produce a literal of some datum type. This will also produce a global+struct representing that datum which will be needed for the C compiler.++-}+++flattenDatum+  :: (ABT Term abt)+  => Datum (abt '[]) (HData' a)+  -> (CExpr -> CodeGen ())+flattenDatum (Datum _ typ code) =+  \loc ->+    do extDeclare $ datumStruct typ+       assignDatum code loc++datumNames :: [String]+datumNames = filter (\n -> not $ elem (head n) ['0'..'9']) names+  where base = ['0'..'9'] ++ ['a'..'z']+        names = [[x] | x <- base] `mplus` (do n <- names+                                              [n++[x] | x <- base])++assignDatum+  :: (ABT Term abt)+  => DatumCode xss (abt '[]) c+  -> CExpr+  -> CodeGen ()+assignDatum code ident =+  let index     = getIndex code+      indexExpr = CMember ident (Ident "index") True+  in  do putExprStat (indexExpr .=. (intE index))+         sequence_ $ assignSum code ident+  where getIndex :: DatumCode xss b c -> Integer+        getIndex (Inl _)    = 0+        getIndex (Inr rest) = succ (getIndex rest)++assignSum+  :: (ABT Term abt)+  => DatumCode xs (abt '[]) c+  -> CExpr+  -> [CodeGen ()]+assignSum code ident = fst $ runState (assignSum' code ident) datumNames++assignSum'+  :: (ABT Term abt)+  => DatumCode xs (abt '[]) c+  -> CExpr+  -> State [String] [CodeGen ()]+assignSum' (Inr rest) topIdent =+  do (_:names) <- get+     put names+     assignSum' rest topIdent+assignSum' (Inl prod) topIdent =+  do (name:_) <- get+     return $ assignProd prod topIdent (CVar . Ident $ name)++assignProd+  :: (ABT Term abt)+  => DatumStruct xs (abt '[]) c+  -> CExpr+  -> CExpr+  -> [CodeGen ()]+assignProd dstruct topIdent sumIdent =+  fst $ runState (assignProd' dstruct topIdent sumIdent) datumNames++assignProd'+  :: (ABT Term abt)+  => DatumStruct xs (abt '[]) c+  -> CExpr+  -> CExpr+  -> State [String] [CodeGen ()]+assignProd' Done _ _ = return []+assignProd' (Et (Konst d) rest) topIdent (CVar sumIdent) =+  do (name:names) <- get+     put names+     let varName  = CMember (CMember (CMember topIdent+                                              (Ident "sum")+                                              True)+                                     sumIdent+                                     True)+                            (Ident name)+                            True+     rest' <- assignProd' rest topIdent (CVar sumIdent)+     return $ [flattenABT d varName] ++ rest'+assignProd' _ _ _  = error $ "TODO: assignProd Ident"+++----------+-- Case --+----------++-- currently we can only match on boolean values+flattenCase+  :: forall abt a b+  .  (ABT Term abt)+  => abt '[] a+  -> [Branch a abt b]+  -> (CExpr -> CodeGen ())++flattenCase c (Branch (PDatum _ (PInl PDone)) trueB:Branch (PDatum _ (PInr (PInl PDone))) falseB:[]) =+  \loc ->+    do cId <- genIdent+       declare (typeOf c) cId+       let cE = (CVar cId)+       flattenABT c cE++       cg <- get+       let trueM    = flattenABT trueB loc+           falseM   = flattenABT falseB loc+           (_,cg')  = runState trueM $ cg { statements = [] }+           (_,cg'') = runState falseM $ cg' { statements = [] }+       put $ cg'' { statements = statements cg }++       putStat $ CIf ((CMember cE (Ident "index") True) .==. (intE 0))+                     (CCompound . fmap CBlockStat . reverse . statements $ cg')+                     Nothing+       putStat $ CIf ((CMember cE (Ident "index") True) .==. (intE 1))+                     (CCompound . fmap CBlockStat . reverse . statements $ cg'')+                     Nothing+++flattenCase _ _ = error "TODO: flattenCase"+++--------------------------------------------------------------------------------+--                                     PrimOp                                 --+--------------------------------------------------------------------------------++flattenPrimOp+  :: ( ABT Term abt+     , typs ~ UnLCs args+     , args ~ LCs typs)+  => PrimOp typs a+  -> SArgs abt args+  -> (CExpr -> CodeGen ())+++flattenPrimOp Pi =+  \End ->+    \loc -> let piE = log1p ((CVar . Ident $ "M_PI") .-. (intE 1)) in+      putExprStat (loc .=. piE)++flattenPrimOp Not =+  \(a :* End) ->+    \_ ->+      -- this is currently incorrect, need to use memcpy to preserve value of+      -- 'a'+      do tmpId <- genIdent' "not"+         declare sBool tmpId+         let tmpE = CVar tmpId+         flattenABT a tmpE+         let datumIndex = CMember tmpE (Ident "index") True+         putExprStat $ datumIndex .=. (CCond (datumIndex .==. (intE 1))+                                             (intE 0)+                                             (intE 1))++flattenPrimOp RealPow =+  \(base :* power :* End) ->+    \loc ->+      do baseId <- genIdent+         powerId <- genIdent+         declare SProb baseId+         declare SReal powerId+         let baseE     = CVar baseId+             powerE = CVar powerId+         flattenABT base baseE -- first argument is a Prob+         flattenABT power powerE+         let realPow = CCall (CVar . Ident $ "pow")+                             [ expm1 baseE .+. (intE 1), powerE]+         putExprStat $ loc .=. (log1p (realPow .-. (intE 1)))++flattenPrimOp (NatPow baseTyp) =+  \(base :* power :* End) ->+    \loc ->+      let sBase = sing_HSemiring baseTyp in+      do baseId <- genIdent+         powerId <- genIdent+         declare sBase baseId+         declare SReal powerId+         let baseE     = CVar baseId+             powerE = CVar powerId+         flattenABT base baseE+         flattenABT power powerE+         let powerOf x y = CCall (CVar . Ident $ "pow") [x,y]+             value = case sBase of+                       SProb -> log1p $ (powerOf (expm1 baseE .+. (intE 1)) powerE)+                                  .-. (intE 1)+                       _     -> powerOf baseE powerE+         putExprStat $ loc .=. value++flattenPrimOp (NatRoot baseTyp) =+  \(base :* root :* End) ->+    \loc ->+      let sBase = sing_HRadical baseTyp in+      do baseId <- genIdent+         rootId <- genIdent+         declare sBase baseId+         declare SReal rootId+         let baseE = CVar baseId+             rootE = CVar rootId+         flattenABT base baseE+         flattenABT root rootE+         let powerOf x y = CCall (CVar . Ident $ "pow") [x,y]+             recipE = (floatE 1) ./. rootE+             value = case sBase of+                       SProb -> log1p $ (powerOf (expm1 baseE .+. (intE 1)) recipE)+                                      .-. (intE 1)+                       _     -> powerOf baseE recipE+         putExprStat $ loc .=. value++flattenPrimOp (Recip t) =+  \(a :* End) ->+    \loc ->+      do aId <- genIdent+         declare (typeOf a) aId+         let aE = CVar aId+         flattenABT a aE+         case t of+           HFractional_Real -> putExprStat $ loc .=. ((intE 1) ./. aE)+           HFractional_Prob -> putExprStat $ loc .=. (CUnary CMinOp aE)++-- | exp : real -> prob, because of this we can just turn it into a prob without taking+--   its log, which would give us an exp in the log-domain+flattenPrimOp Exp = \(a :* End) -> flattenABT a++flattenPrimOp (Equal _) =+  \(a :* b :* End) ->+    \loc ->+      do aId <- genIdent+         bId <- genIdent+         let aE = CVar aId+             bE = CVar bId+             aT = typeOf a+             bT = typeOf b+         declare aT aId+         declare bT bId+         flattenABT a aE+         flattenABT b bE++         -- special case for booleans+         let aE' = case aT of+                     (SData _ (SPlus SDone (SPlus SDone SVoid))) -> (CMember aE (Ident "index") True)+                     _ -> aE+         let bE' = case bT of+                     (SData _ (SPlus SDone (SPlus SDone SVoid))) -> (CMember bE (Ident "index") True)+                     _ -> bE++         putExprStat $   (CMember loc (Ident "index") True)+                     .=. (CCond (aE' .==. bE') (intE 0) (intE 1))+++flattenPrimOp (Less _) =+  \(a :* b :* End) ->+    \loc ->+      do aId <- genIdent+         bId <- genIdent+         let aE = CVar aId+             bE = CVar bId+         declare (typeOf a) aId+         declare (typeOf b) bId+         flattenABT a aE+         flattenABT b bE+         putExprStat $ (CMember loc (Ident "index") True)+                     .=. (CCond (aE .<. bE) (intE 0) (intE 1))++flattenPrimOp (Negate HRing_Real) =+ \(a :* End) ->+   \loc ->+     do negId <- genIdent' "neg"+        declare SReal negId+        let negE = CVar negId+        flattenABT a negE+        putExprStat $ loc .=. (CUnary CMinOp $ negE)+++flattenPrimOp t  = \_ -> error $ "TODO: flattenPrimOp: " ++ show t+++--------------------------------------------------------------------------------+--                           MeasureOps and Superpose                         --+--------------------------------------------------------------------------------++{-++The sections contains operations in the stochastic monad. See also+(Dirac, MBind, and Plate) found in SCon. Also see Reject found at the top level.++Remember in the C runtime. Measures are housed in a measure function, which+takes an `struct mdata` location. The MeasureOp attempts to store a value at+that location and returns 0 if it fails and 1 if it succeeds in that task.++The functions uniformCG, normalCG, and gammaCG are primitives that will generate+functions and call them (similar to logSumExpCG). The reduce code size and make+samplers a little more readable.++TODO: add inline pragmas to uniformCG, normalCG, and gammaCG+-}++uniformFun :: CFunDef+uniformFun = CFunDef [CTypeSpec CVoid]+                     (CDeclr Nothing [CDDeclrIdent funcId])+                     [typeDeclaration SReal loId+                     ,typeDeclaration SReal hiId+                     ,typePtrDeclaration (SMeasure SReal) mId]+                     (seqCStat $ comment ++[assW,assS,CReturn Nothing])+  where r          = CCast doubleDecl rand+        rMax       = CCast doubleDecl (CVar . Ident $ "RAND_MAX")+        (mId,mE)   = let ident = Ident "mdata" in (ident,CVar ident)+        (loId,loE) = let ident = Ident "lo" in (ident,CVar ident)+        (hiId,hiE) = let ident = Ident "hi" in (ident,CVar ident)+        value      = (loE .+. ((r ./. rMax) .*. (hiE .-. loE)))+        comment = fmap CComment+          ["uniform :: real -> real -> *(mdata real) -> ()"+          ,"------------------------------------------------"]+        assW       = CExpr . Just $ mdataPtrWeight mE .=. (floatE 0)+        assS       = CExpr . Just $ mdataPtrSample mE .=. value+        funcId     = Ident "uniform"+++uniformCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())+uniformCG aE bE =+  \loc -> do+    reserveName "uniform"+    extDeclare . CFunDefExt $ uniformFun+    putExprStat $ CCall (CVar . Ident $ "uniform") [aE,bE,loc]+++{-+  This is very cryptic, but I assure you it is only building an AST for the+  Marsaglia Polar Method+-}++normalFun :: CFunDef+normalFun = CFunDef [CTypeSpec CVoid]+                    (CDeclr Nothing [CDDeclrIdent (Ident "normal")])+                    [typeDeclaration SReal aId+                    ,typeDeclaration SProb bId+                    ,typePtrDeclaration (SMeasure SReal) mId]+                    (CCompound $ comment ++ decls ++ stmts)++  where r      = CCast doubleDecl rand+        rMax   = CCast doubleDecl (CVar . Ident $ "RAND_MAX")+        (aId,aE) = let ident = Ident "a" in (ident,CVar ident)+        (bId,bE) = let ident = Ident "b" in (ident,CVar ident)+        (qId,qE) = let ident = Ident "q" in (ident,CVar ident)+        (uId,uE) = let ident = Ident "u" in (ident,CVar ident)+        (vId,vE) = let ident = Ident "v" in (ident,CVar ident)+        (rId,rE) = let ident = Ident "r" in (ident,CVar ident)+        (mId,mE) = let ident = Ident "mdata" in (ident,CVar ident)+        draw xE = CExpr . Just $ xE .=. (((r ./. rMax) .*. (floatE 2)) .-. (floatE 1))+        body = seqCStat [draw uE+                        ,draw vE+                        ,CExpr . Just $ qE .=. ((uE .*. uE) .+. (vE .*. vE))]+        polar = CWhile (qE .>. (floatE 1)) body True+        setR  = CExpr . Just $ rE .=. (sqrt (((CUnary CMinOp (floatE 2)) .*. log qE) ./. qE))+        finalValue = aE .+. (uE .*. rE .*. bE)+        comment = fmap (CBlockStat . CComment)+          ["normal :: real -> real -> *(mdata real) -> ()"+          ,"Marsaglia Polar Method"+          ,"-----------------------------------------------"]+        decls = fmap (CBlockDecl . typeDeclaration SReal) [uId,vId,qId,rId]+        stmts = fmap CBlockStat [polar,setR, assW, assS,CReturn Nothing]+        assW = CExpr . Just $ mdataPtrWeight mE .=. (floatE 0)+        assS = CExpr . Just $ mdataPtrSample mE .=. finalValue+++normalCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())+normalCG aE bE =+  \loc -> do+    reserveName "normal"+    extDeclare . CFunDefExt $ normalFun+    putExprStat $ CCall (CVar . Ident $ "normal") [aE,bE,loc]++{-+  This method is from Marsaglia and Tsang "a simple method for generating gamma variables"+-}+gammaFun :: CFunDef+gammaFun = CFunDef [CTypeSpec CVoid]+                   (CDeclr Nothing [CDDeclrIdent (Ident "gamma")])+                   [typeDeclaration SProb aId+                   ,typeDeclaration SProb bId+                   ,typePtrDeclaration (SMeasure SProb) mId]+                   (CCompound $ comment ++ decls ++ stmts)+  where (aId,aE) = let ident = Ident "a" in (ident,CVar ident)+        (bId,bE) = let ident = Ident "b" in (ident,CVar ident)+        (cId,cE) = let ident = Ident "c" in (ident,CVar ident)+        (dId,dE) = let ident = Ident "d" in (ident,CVar ident)+        (xId,xE) = let ident = Ident "x" in (ident,CVar ident)+        (vId,vE) = let ident = Ident "v" in (ident,CVar ident)+        (uId,uE) = let ident = Ident "u" in (ident,CVar ident)+        (mId,mE) = let ident = Ident "mdata" in (ident,CVar ident)+        comment = fmap (CBlockStat . CComment)+          ["gamma :: real -> prob -> *(mdata prob) -> ()"+          ,"Marsaglia and Tsang 'a simple method for generating gamma variables'"+          ,"--------------------------------------------------------------------"]+        decls = fmap CBlockDecl $ (fmap (typeDeclaration SReal) [dId,cId,vId])+                               ++ (fmap (typeDeclaration (SMeasure SReal)) [uId,xId])+        stmts = fmap CBlockStat $ [assD,assC,outerWhile]+        xS = mdataSample xE+        uS = mdataSample uE+        assD = CExpr . Just $ dE .=. (aE .-. ((floatE 1) ./. (floatE 3)))+        assC = CExpr . Just $ cE .=. ((floatE 1) ./. (sqrt ((floatE 9) .*. dE)))+        outerWhile = CWhile (intE 1) (seqCStat [innerWhile,assV,assU,exit]) False+        innerWhile = CWhile (vE .<=. (floatE 0)) (seqCStat [assX,assVIn]) True+        assX = CExpr . Just $ CCall (CVar . Ident $ "normal") [(floatE 0),(floatE 1),address xE]+        assVIn = CExpr . Just $ vE .=. ((floatE 1) .+. (cE .*. xS))+        assV = CExpr . Just $ vE .=. (vE .*. vE .*. vE)+        assU = CExpr . Just $ CCall (CVar . Ident $ "uniform") [(floatE 0),(floatE 1),address uE]+        exitC1 = uS .<. ((floatE 1) .-. ((floatE 0.331 .*. (xS .*. xS) .*. (xS .*. xS))))+        exitC2 = (log uS) .<. (((floatE 0.5) .*. (xS .*. xS)) .+. (dE .*. ((floatE 1.0) .-. vE .+. (log vE))))+        assW = CExpr . Just $ mdataPtrWeight mE .=. (floatE 0)+        assS = CExpr . Just $ mdataPtrSample mE .=. (log (dE .*. vE)) .+. bE+        exit = CIf (exitC1 .||. exitC2) (seqCStat [assW,assS,CReturn Nothing]) Nothing+++gammaCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())+gammaCG aE bE =+  \loc -> do+     extDeclare $ mdataStruct SReal+     mapM_ reserveName ["uniform","normal","gamma"]+     mapM_ (extDeclare . CFunDefExt) [uniformFun,normalFun,gammaFun]+     putExprStat $ CCall (CVar . Ident $ "gamma") [aE,bE,loc]+++flattenMeasureOp+  :: forall abt typs args a .+     ( ABT Term abt+     , typs ~ UnLCs args+     , args ~ LCs typs )+  => MeasureOp typs a+  -> SArgs abt args+  -> (CExpr -> CodeGen ())+++flattenMeasureOp Uniform =+  \(a :* b :* End) ->+    \loc ->+      do (aId:bId:[]) <- replicateM 2 genIdent+         let aE = CVar aId+             bE = CVar bId+         declare SReal aId+         declare SReal bId+         flattenABT a aE+         flattenABT b bE+         uniformCG aE bE loc+++flattenMeasureOp Normal  =+  \(a :* b :* End) ->+    \loc ->+      do (aId:bId:[]) <- replicateM 2 genIdent+         let aE = CVar aId+             bE = CVar bId+         declare SReal aId+         declare SReal bId+         flattenABT a aE+         flattenABT b bE+         normalCG aE (exp bE) loc+++flattenMeasureOp Gamma =+  \(a :* b :* End) ->+    \loc ->+      do (aId:bId:[]) <- replicateM 2 genIdent+         let aE = CVar aId+             bE = CVar bId+         declare SReal aId+         declare SReal bId+         flattenABT a aE+         flattenABT b bE+         gammaCG (exp aE) bE loc+++flattenMeasureOp Beta =+  \(a :* b :* End) -> flattenABT (HKP.beta'' a b)+++flattenMeasureOp Categorical = \(arr :* End) ->+  \loc ->+    do arrId <- genIdent+       declare (typeOf arr) arrId+       let arrE = CVar arrId+       flattenABT arr arrE++       itId <- genIdent' "it"+       declare SInt itId+       let itE = CVar itId++       wSumId <- genIdent' "ws"+       declare SProb wSumId+       let wSumE = CVar wSumId+       assign wSumId (log (intE 0))++       let currE = indirect (arrayData arrE .+. itE)+           cond  = itE .<. (arraySize arrE)+           inc   = CUnary CPostIncOp itE++       isPar <- isParallel+       mkSequential++       -- first calculate the max weight+       forCG (itE .=. (intE 0)) cond inc $+         logSumExpCG (S.fromList [wSumE,currE]) wSumE++       -- draw number from uniform(0, weightSum)+       rId <- genIdent' "r"+       declare SReal rId+       let r    = CCast doubleDecl rand+           rMax = CCast doubleDecl (CVar . Ident $ "RAND_MAX")+           rE = CVar rId+       assign rId ((r ./. rMax) .*. (exp wSumE))++       assign wSumId (log (intE 0))+       assign itId (intE 0)+       whileCG (intE 1)+         $ do stat <- runCodeGenBlock $+                        do putExprStat $ mdataPtrWeight loc .=. (intE 0)+                           putExprStat $ mdataPtrSample loc .=. itE+                           putStat CBreak+              putStat $ CIf (rE .<. (exp wSumE)) stat Nothing+              logSumExpCG (S.fromList [wSumE,currE]) wSumE+              putExprStat $ CUnary CPostIncOp itE++       when isPar mkParallel+++flattenMeasureOp x = error $ "TODO: flattenMeasureOp: " ++ show x++---------------+-- Superpose --+---------------++flattenSuperpose+    :: (ABT Term abt)+    => NE.NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))+    -> (CExpr -> CodeGen ())++-- do we need to normalize?+flattenSuperpose pairs =+  let pairs' = NE.toList pairs in++  if length pairs' == 1+  then \loc -> let (w,m) = head pairs' in+         do mId <- genIdent+            wId <- genIdent+            declare (typeOf m) mId+            declare SProb wId+            let mE = address . CVar $ mId+                wE = CVar wId+            flattenABT w wE+            flattenABT m mE+            putExprStat $ mdataPtrWeight loc .=. ((mdataPtrWeight mE) .+. wE)+            putExprStat $ mdataPtrSample loc .=. (mdataPtrSample mE)++  else \loc ->+         do wEs <- forM pairs' $ \(w,_) ->+                     do wId <- genIdent' "w"+                        declare SProb wId+                        let wE = CVar wId+                        flattenABT w wE+                        return wE++            wSumId <- genIdent' "ws"+            declare SProb wSumId+            let wSumE = CVar wSumId+            logSumExpCG (S.fromList wEs) wSumE++            -- draw number from uniform(0, weightSum)+            rId <- genIdent' "r"+            declare SReal rId+            let r    = CCast doubleDecl rand+                rMax = CCast doubleDecl (CVar . Ident $ "RAND_MAX")+                rE = CVar rId+            assign rId ((r ./. rMax) .*. (exp wSumE))++            -- an iterator for picking a measure+            itId <- genIdent' "it"+            declare SProb itId+            let itE = CVar itId+            assign itId (log (intE 0))++            -- an output measure to assign to+            outId <- genIdent' "out"+            declare (typeOf . snd . head $ pairs') outId+            let outE = address $ CVar outId++            outLabel <- genIdent' "exit"++            forM_ (zip wEs pairs')+              $ \(wE,(_,m)) ->+                  do logSumExpCG (S.fromList [itE,wE]) itE+                     stat <- runCodeGenBlock (flattenABT m outE >> putStat (CGoto outLabel))+                     putStat $ CIf (rE .<. (exp itE)) stat Nothing++            putStat $ CLabel outLabel (CExpr Nothing)+            putExprStat $ mdataPtrWeight loc .=. ((mdataPtrWeight outE) .+. wSumE)+            putExprStat $ mdataPtrSample loc .=. (mdataPtrSample outE)

@@ -0,0 +1,295 @@+--------------------------------------------------------------------------------+--                                                                  2016.09.08+-- |+-- Module      :  Language.Hakaru.CodeGen.Pretty+-- Copyright   :  Copyright (c) 2016 the Hakaru team+-- License     :  BSD3+-- Maintainer  :  zsulliva@indiana.edu+-- Stability   :  experimental+-- Portability :  GHC-only+--+--   A pretty printer for the CodeGen AST+--+--------------------------------------------------------------------------------++module Language.Hakaru.CodeGen.Pretty+  ( pretty+  , prettyPrint+  , Pretty+  ) where++import Text.PrettyPrint+import Language.Hakaru.CodeGen.AST++prettyPrint :: Pretty a => a -> String+prettyPrint = render . pretty++class Pretty a where+  pretty :: a -> Doc+  prettyPrec :: Int -> a -> Doc++  pretty = prettyPrec 0+  prettyPrec _ = pretty++mpretty :: Pretty a => Maybe a -> Doc+mpretty Nothing  = empty+mpretty (Just x) = pretty x++mPrettyPrec :: Pretty a => Int -> Maybe a -> Doc+mPrettyPrec _ Nothing  = empty+mPrettyPrec p (Just x) = prettyPrec p x++-- will compare two precs and put parens if the prec is lower+parensPrec :: Int -> Int -> Doc -> Doc+parensPrec x y = if x <= y then parens else id++newline :: Doc+newline = char '\n'++--------------------------------------------------------------------------------+--                                  Top Level                                 --+--------------------------------------------------------------------------------++instance Pretty Ident where+  pretty (Ident i) = text i++instance Pretty CAST where+  pretty (CAST extdecls) = (vcat . fmap pretty $ extdecls) $$ newline++instance Pretty CExtDecl where+  pretty (CDeclExt d) =  newline <> pretty d <> semi+  pretty (CFunDefExt f) = newline <> pretty f+  pretty (CCommentExt s) = text "/*" <+> text s <+> text "*/"+  pretty (CPPExt p) = pretty p++instance Pretty CFunDef where+  pretty (CFunDef dspecs dr ds s) =+    ((hsep . fmap pretty $ dspecs)+     <+> pretty dr+     <>  (parens . hsep . punctuate comma . fmap pretty $ ds))+    $+$ pretty s++--------------------------------------------------------------------------------+--                               Preprocessor                                 --+--------------------------------------------------------------------------------++instance Pretty Preprocessor where+  pretty (PPDefine n x) = hsep . fmap text $ ["#define",n,x]+  pretty (PPInclude s) = text "#include" <+> text "<" <> text s <> text ">"+  pretty (PPUndef s) = text "#undef" <+> text s+  pretty (PPIf s) = text "#if" <+> text s+  pretty (PPIfDef s) = text "#ifdef" <+> text s+  pretty (PPIfNDef s) = text "#ifndef" <+> text s+  pretty (PPElse s) = text "#else" <+> text s+  pretty (PPElif s) = text "#elif" <+> text s+  pretty (PPEndif s) = text "#endif" <+> text s+  pretty (PPError s) = text "#error" <+> text s+  pretty (PPPragma ts) = space $$ text "#pragma" <+> (hsep . fmap text $ ts)+++--------------------------------------------------------------------------------+--                             CDeclarations                                  --+--------------------------------------------------------------------------------++instance Pretty CDecl where+  pretty (CDecl ds ps) =+    hsep [ hsep . fmap pretty $ ds+         , hsep . punctuate comma . fmap declarators $ ps]+    where declarators (dr, Nothing) = pretty dr+          declarators (dr, Just ilist) = pretty dr <+> text "=" <+> pretty ilist++instance Pretty CDeclr where+  pretty (CDeclr mp dds) =+    mpretty mp <+> (hsep . fmap pretty $ dds)++instance Pretty CPtrDeclr where+  pretty (CPtrDeclr ts) = text "*" <+> (hsep . fmap pretty $ ts)++instance Pretty CDirectDeclr where+  pretty (CDDeclrIdent i) = pretty i+  pretty (CDDeclrArr dd e) = pretty dd <+> (brackets . pretty $ e)+  pretty (CDDeclrFun dd ts) =+    pretty dd <+> (hsep . punctuate comma . fmap pretty $ ts)+++instance Pretty CDeclSpec where+  pretty (CStorageSpec ss) = pretty ss+  pretty (CTypeSpec ts) = pretty ts+  pretty (CTypeQual tq) = pretty tq+  pretty (CFunSpec _ ) = text "inline"  -- inline is the only CFunSpec++instance Pretty CStorageSpec where+  pretty CTypeDef = text "typedef"+  pretty CExtern = text "extern"+  pretty CStatic = text "static"+  pretty CAuto = text "auto"+  pretty CRegister = text "register"++instance Pretty CTypeQual where+  pretty CConstQual = text "const"+  pretty CVolatQual = text "volatile"++instance Pretty CTypeSpec where+  pretty CVoid = text "void"+  pretty CChar = text "char"+  pretty CShort = text "short"+  pretty CInt = text "int"+  pretty CLong = text "long"+  pretty CFloat = text "float"+  pretty CDouble = text "double"+  pretty CSigned = text "signed"+  pretty CUnsigned = text "unsigned"+  pretty (CSUType cs) = pretty cs+  pretty (CTypeDefType _) = error "TODO: Pretty TypeDef"+  pretty (CEnumType _) = error "TODO: Pretty EnumType"++instance Pretty CSUSpec where+  pretty (CSUSpec tag mi []) =+    pretty tag <+> mpretty mi+  pretty (CSUSpec tag mi ds) =+    (pretty tag <+> mpretty mi <+> lbrace)+    $+$ (nest (-1) $ (nest 2 . sep . fmap (\d -> pretty d <> semi)  $ ds)+                     $+$ rbrace)++instance Pretty CSUTag where+  pretty CStructTag = text "struct"+  pretty CUnionTag = text "union"++instance Pretty CEnum where+  pretty (CEnum _ _) = error "TODO: Pretty Enum"++instance Pretty CInit where+  pretty (CInitExpr _) = error "TODO: Pretty Init"+  pretty (CInitList _) = error "TODO: Pretty Init list"++instance Pretty CPartDesig where+  pretty (CArrDesig _) = error "TODO: Pretty Arr Desig"+  pretty (CMemberDesig _) = error "TODO: Pretty Memdesig"+++--------------------------------------------------------------------------------+--                                CStatements                                 --+--------------------------------------------------------------------------------++instance Pretty CStat where+  pretty (CLabel lId s) = pretty lId <> colon $$ nest 2 (pretty s)+  pretty (CGoto lId) = text "goto" <+> pretty lId <> semi+  pretty (CSwitch e s) = text "switch" <+> pretty e <+> (parens . pretty $ s )+  pretty (CCase e s) = text "case" <+> pretty e <> colon $$ nest 2 (pretty s)+  pretty (CDefault s) = text "default" <> colon $$ nest 2 (pretty s)+  pretty (CExpr me) = mpretty me <> semi+  pretty (CCompound bs) =+    nest (-1) (lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace)++  pretty (CIf ce thns (Just elss)) = nest 1 $+    text "if" <+> (parens . prettyPrec (-5) $ ce)+              $+$ (nest 1 $ pretty thns)+              $+$ text "else"+              $+$ (nest 1 $ pretty elss)+  pretty (CIf ce thns Nothing) =+    text "if" <+> (parens . prettyPrec (-5) $ ce) $+$ (nest 1 $ pretty thns)++  pretty (CWhile ce s b) =+    if b+    then text "do" <+> pretty s <+> text "while" <+> (parens $ pretty ce) <> semi+    else text "while" <+> (parens $ pretty ce) $$ (nest 1 $ pretty s)++  pretty (CFor me mce mie s) =+    text "for"+    <+> (parens . hsep . punctuate semi . fmap (mPrettyPrec 10) $ [me,mce,mie])+    $$  (nest 1 $ pretty s)++  pretty CCont = text "continue" <> semi+  pretty CBreak = text "break" <> semi+  pretty (CReturn me) = text "return" <+> mpretty me  <> semi+  pretty (CComment s) = text "/*" <+> text s <+> text "*/"+  pretty (CPPStat p) = pretty p++instance Pretty CCompoundBlockItem where+  pretty (CBlockStat s) = pretty s+  pretty (CBlockDecl d) = pretty d <> semi+++--------------------------------------------------------------------------------+--                                CExpressions                                --+--------------------------------------------------------------------------------++instance Pretty CExpr where+  prettyPrec _ (CComma es) = hsep . punctuate comma . fmap pretty $ es+  prettyPrec _ (CAssign op le re) = pretty le <+> pretty op <+> pretty re+  prettyPrec _ (CCond ce thn els) = pretty ce <+> text "?" <+> pretty thn <+> colon <+> pretty els+  prettyPrec p (CBinary op e1 e2) =+    parensPrec p 0 . hsep $ [pretty e1, pretty op, pretty e2]+  prettyPrec p (CCast d e) =+    parensPrec p (2) $ parens (pretty d) <> pretty e+  prettyPrec p (CUnary op e) =+    if elem op [CPostIncOp,CPostDecOp]+    then parensPrec p (-1) $ prettyPrec (-1) e <> pretty op+    else parens $ pretty op <> prettyPrec (-1) e++  prettyPrec _ (CSizeOfExpr e) = text "sizeof" <> (parens . pretty $ e)+  prettyPrec _ (CSizeOfType d) = text "sizeof" <> (parens . pretty $ d)+  prettyPrec _ (CIndex arrId ie) = pretty arrId <> (brackets . pretty $ ie)+  prettyPrec _ (CCall fune es) =+    pretty fune <> (parens . hcat . punctuate comma . fmap pretty $ es)+  prettyPrec _ (CMember ve memId isPtr) =+    let op = text $ if isPtr then "." else "->"+    in  pretty ve <> op <> pretty memId+  prettyPrec _ (CVar varId) = pretty varId+  prettyPrec _ (CConstant c) = pretty c+  prettyPrec _ (CCompoundLit d ini) = parens (pretty d) <> pretty ini+++instance Pretty CAssignOp where+  pretty CAssignOp = text "="+  pretty CMulAssOp = text "*="+  pretty CDivAssOp = text "/="+  pretty CRmdAssOp = text "%="+  pretty CAddAssOp = text "+="+  pretty CSubAssOp = text "-="+  pretty CShlAssOp = text "<<="+  pretty CShrAssOp = text ">>="+  pretty CAndAssOp = text "&="+  pretty CXorAssOp = text "^="+  pretty COrAssOp  = text "|="+++instance Pretty CBinaryOp where+  pretty CMulOp = text "*"+  pretty CDivOp = text "/"+  pretty CRmdOp = text "%"+  pretty CAddOp = text "+"+  pretty CSubOp = text "-"+  pretty CShlOp = text "<<"+  pretty CShrOp = text ">>"+  pretty CLeOp  = text "<"+  pretty CGrOp  = text ">"+  pretty CLeqOp = text "<="+  pretty CGeqOp = text ">="+  pretty CEqOp  = text "=="+  pretty CNeqOp = text "!="+  pretty CAndOp = text "&"+  pretty CXorOp = text "^"+  pretty COrOp  = text "|"+  pretty CLndOp = text "&&"+  pretty CLorOp = text "||"+++instance Pretty CUnaryOp where+  pretty CPreIncOp  = text "++"+  pretty CPreDecOp  = text "--"+  pretty CPostIncOp = text "++"+  pretty CPostDecOp = text "--"+  pretty CAdrOp     = text "&"+  pretty CIndOp     = text "*"+  pretty CPlusOp    = text "+"+  pretty CMinOp     = text "-"+  pretty CCompOp    = text "~"+  pretty CNegOp     = text "!"+++instance Pretty CConst where+  pretty (CIntConst i)    = text . show $ i+  pretty (CCharConst c)   = char c+  pretty (CFloatConst f)  = float f+  pretty (CStringConst s) = text . show $ s

@@ -0,0 +1,349 @@+{-# 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+  , buildPtrDeclaration++  -- tools for building C types+  , typeDeclaration+  , typePtrDeclaration++  -- arrays+  , arrayDeclaration+  , arrayName+  , arrayStruct+  , arraySize+  , arrayData+  , arrayPtrSize+  , arrayPtrData++  -- mdata+  , mdataDeclaration+  , mdataPtrDeclaration+  , mdataName+  , mdataStruct+  , mdataStruct'+  , mdataWeight+  , mdataSample+  , mdataPtrWeight+  , mdataPtrSample++  , datumDeclaration+  , datumName+  , datumStruct+  , functionDef+  , datumSum+  , datumProd++  , buildType+  , mkDecl+  , mkPtrDecl+  , buildStruct+  , buildUnion++  , intDecl+  , natDecl+  , doubleDecl+  , doublePtr+  , intPtr+  , natPtr+  , boolTyp+  , 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 Prelude hiding (exp,log,sqrt)++buildDeclaration :: CTypeSpec -> Ident -> CDecl+buildDeclaration ctyp ident =+  CDecl [ CTypeSpec ctyp ]+        [( 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)]++--------------------------------------------------------------------------------+-- Representing Hakaru Arrays++arrayName :: Sing (a :: Hakaru) -> String+arrayName SInt  = "arrayInt"+arrayName SNat  = "arrayNat"+arrayName SReal = "arrayReal"+arrayName SProb = "arrayProb"+arrayName t    = error $ "arrayName: cannot make array from type: " ++ show t++arrayStruct :: Sing (a :: Hakaru) -> CExtDecl+arrayStruct t = CDeclExt (CDecl [CTypeSpec $ arrayStruct' t] [])++arrayStruct' :: Sing (a :: Hakaru) -> CTypeSpec+arrayStruct' t = aStruct+  where aSize   = buildDeclaration CInt (Ident "size")+        aData   = typePtrDeclaration t (Ident "data")+        aStruct = buildStruct (Just . Ident . arrayName $ t) [aSize,aData]+++arrayDeclaration+  :: Sing (a :: Hakaru)+  -> Ident+  -> CDecl+arrayDeclaration typ = buildDeclaration (callStruct (arrayName typ))+++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++mdataName :: Sing (a :: Hakaru) -> String+mdataName SInt  = "mdataInt"+mdataName SNat  = "mdataNat"+mdataName SReal = "mdataReal"+mdataName SProb = "mdataProb"+mdataName (SArray SInt)  = "mdataArrayInt"+mdataName (SArray SNat)  = "mdataArrayNat"+mdataName (SArray SReal) = "mdataArrayReal"+mdataName (SArray SProb) = "mdataArrayProb"+mdataName t    = error $ "mdataName: cannot make mdata from type: " ++ show t++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 . mdataName $ t) [weight,sample]++mdataDeclaration+  :: Sing (a :: Hakaru)+  -> Ident+  -> CDecl+mdataDeclaration typ = buildDeclaration (callStruct (mdataName typ))++mdataPtrDeclaration+  :: Sing (a :: Hakaru)+  -> Ident+  -> CDecl+mdataPtrDeclaration typ = buildPtrDeclaration (callStruct (mdataName typ))++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++--------------------------------------------------------------------------------+-- | datumProd and datumSum use a store of names, which needs to match up with+-- the names used when they are assigned and printed+-- datumDeclaration declares struct internally+-- datumStruct declares struct definitions externally++-- | datumName provides a unique name to identify a struct type+datumName :: Sing (a :: [[HakaruFun]]) -> String+datumName SVoid = "V"+datumName (SPlus prodD sumD) = concat ["S",datumName' prodD,datumName sumD]+  where datumName' :: Sing (a :: [HakaruFun]) -> String+        datumName' SDone = "U"+        datumName' (SEt (SKonst x) prod') = concat ["S",tail . show $ x,datumName' prod']+        datumName' (SEt SIdent _)         = error "TODO: datumName of SIdent"++datumNames :: [String]+datumNames = filter (\n -> not $ elem (head n) ['0'..'9']) names+  where base = ['0'..'9'] ++ ['a'..'z']+        names = [[x] | x <- base] `mplus` (do n <- names+                                              [n++[x] | x <- base])++datumStruct :: (Sing (HData' t)) -> CExtDecl+datumStruct (SData _ typ) = CDeclExt $ datumSum typ (Ident (datumName typ))++datumDeclaration+  :: (Sing (HData' t))+  -> Ident+  -> CDecl+datumDeclaration (SData _ typ) = buildDeclaration (callStruct (datumName typ))++datumSum :: Sing (a :: [[HakaruFun]]) -> Ident -> CDecl+datumSum funs ident =+  let declrs = fst $ runState (datumSum' funs) datumNames+      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 (a :: [[HakaruFun]]) -> State [String] [CDecl]+datumSum' SVoid          = return []+datumSum' (SPlus prod rest) =+  do (name:names) <- get+     put names+     let ident = Ident name+         mdecl = datumProd prod ident+     rest' <- datumSum' rest+     case mdecl of+       Nothing -> return rest'+       Just d  -> return $ [d] ++ rest'+++datumProd :: Sing (a :: [HakaruFun]) -> Ident -> Maybe CDecl+datumProd SDone _     = Nothing+datumProd funs ident  =+  let declrs = fst $ runState (datumProd' funs) datumNames+  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 (a :: [HakaruFun]) -> State [String] [CDecl]+datumProd' SDone                 = return []+datumProd' (SEt (SKonst t) rest) =+  do (name:names) <- get+     put names+     let ident = Ident name+         decl  = typeDeclaration t ident+     rest' <- datumProd' rest+     return $ [decl] ++ rest'+datumProd' (SEt SIdent _) = error "TODO: datumProd' SIdent"++----------------------------------------------------------------++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)))++----------------------------------------------------------------+-- | 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 . mdataName $ x]+buildType (SArray t)   = [callStruct $ arrayName t]+buildType (SFun _ x)   = buildType $ x -- build type the function returns+buildType (SData _ t)  = [callStruct $ datumName t]+++-- these mk...Decl functions are used in coersions+mkDecl :: [CTypeSpec] -> CDecl+mkDecl t = CDecl (fmap CTypeSpec t) []++mkPtrDecl :: [CTypeSpec] -> CDecl+mkPtrDecl t = CDecl (fmap CTypeSpec t)+                    [( CDeclr (Just $ CPtrDeclr []) []+                     , Nothing )]++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)+++intDecl, natDecl, doubleDecl :: CDecl+intDecl    = mkDecl [CInt]+natDecl    = CDecl [CTypeSpec CUnsigned+                   ,CTypeSpec CInt]+                   [( CDeclr (Just $ CPtrDeclr []) [], Nothing )]+doubleDecl = mkDecl [CDouble]++intPtr, natPtr, doublePtr :: CDecl+intPtr    = mkPtrDecl [CInt]+natPtr    = CDecl [CTypeSpec CUnsigned, CTypeSpec CInt] []+doublePtr = mkPtrDecl [CDouble]++boolTyp :: CDecl+boolTyp =+  CDecl [CTypeSpec+          (CSUType+            (CSUSpec CStructTag+                     (Just (Ident "bool"))+                     [buildDeclaration CInt (Ident "index")]))]+        []++++binaryOp :: NaryOp a -> CExpr -> CExpr -> CExpr+binaryOp (Sum HSemiring_Prob)  a b = CBinary CAddOp (exp a) (exp 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