-- Copyright (c) 2016 and after, see package copyright

-- Copyright (c) 2015, Anders Persson
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
--
--     * Neither the name of Anders Persson nor the names of other
--       contributors may be used to endorse or promote products derived
--       from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- Copyright (c) 2011-2012, Geoffrey Mainland
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without modification,
-- are permitted provided that the following conditions are met:
-- 1. Redistributions of source code must retain the above copyright notice, this
--    list of conditions and the following disclaimer.
--
-- 2. Redistributions in binary form must reproduce the above copyright notice,
--    this list of conditions and the following disclaimer in the documentation
--    and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
-- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- Copyright (c) 2009-2010
--         The President and Fellows of Harvard College.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
-- 1. Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
-- 3. Neither the name of the University nor the names of its contributors
--    may be used to endorse or promote products derived from this software
--    without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-- ARE DISCLAIMED.  IN NO EVENT SHALL THE UNIVERSITY OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-- SUCH DAMAGE.

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | A monad for C code generation
module Language.C.Monad
  where

import Lens.Micro.Mtl
import Lens.Micro.TH
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Identity
import Control.Monad.State.Strict
import Control.Monad.Exception

import Language.C.Quote.C
import qualified Language.C.Syntax as C
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Monoid
import Text.PrettyPrint.Mainland
#if MIN_VERSION_mainland_pretty(0,6,0)
import Text.PrettyPrint.Mainland.Class
#endif
import Data.Loc
import Data.List (partition,nub)

-- | Code generation flags
data Flags = Flags

-- | Code generator state.
data CEnv = CEnv
    { CEnv -> Flags
_flags       :: Flags

    , CEnv -> Integer
_unique      :: !Integer

    , CEnv -> Map String [Definition]
_modules     :: Map.Map String [C.Definition]
    , CEnv -> Set String
_includes    :: Set.Set String
    , CEnv -> [Definition]
_typedefs    :: [C.Definition]
    , CEnv -> [Definition]
_prototypes  :: [C.Definition]
    , CEnv -> [Definition]
_globals     :: [C.Definition]

    , CEnv -> Map Integer String
_aliases     :: Map.Map Integer String
    , CEnv -> [Param]
_params      :: [C.Param]
    , CEnv -> [Exp]
_args        :: [C.Exp]
    , CEnv -> [InitGroup]
_locals      :: [C.InitGroup]
    , CEnv -> [BlockItem]
_items       :: [C.BlockItem]
    , CEnv -> [BlockItem]
_finalItems  :: [C.BlockItem]

    , CEnv -> Set Id
_usedVars    :: Set.Set C.Id
    , CEnv -> Map String (Set Id)
_funUsedVars :: Map.Map String (Set.Set C.Id)
    }

makeLenses ''CEnv

-- | Default code generator state
defaultCEnv :: Flags -> CEnv
defaultCEnv :: Flags -> CEnv
defaultCEnv Flags
fl = CEnv :: Flags
-> Integer
-> Map String [Definition]
-> Set String
-> [Definition]
-> [Definition]
-> [Definition]
-> Map Integer String
-> [Param]
-> [Exp]
-> [InitGroup]
-> [BlockItem]
-> [BlockItem]
-> Set Id
-> Map String (Set Id)
-> CEnv
CEnv
    { _flags :: Flags
_flags       = Flags
fl
    , _unique :: Integer
_unique      = Integer
0
    , _modules :: Map String [Definition]
_modules     = Map String [Definition]
forall a. Monoid a => a
mempty
    , _includes :: Set String
_includes    = Set String
forall a. Monoid a => a
mempty
    , _typedefs :: [Definition]
_typedefs    = [Definition]
forall a. Monoid a => a
mempty
    , _prototypes :: [Definition]
_prototypes  = [Definition]
forall a. Monoid a => a
mempty
    , _globals :: [Definition]
_globals     = [Definition]
forall a. Monoid a => a
mempty
    , _aliases :: Map Integer String
_aliases     = Map Integer String
forall a. Monoid a => a
mempty
    , _params :: [Param]
_params      = [Param]
forall a. Monoid a => a
mempty
    , _args :: [Exp]
_args        = [Exp]
forall a. Monoid a => a
mempty
    , _locals :: [InitGroup]
_locals      = [InitGroup]
forall a. Monoid a => a
mempty
    , _items :: [BlockItem]
_items       = [BlockItem]
forall a. Monoid a => a
mempty
    , _finalItems :: [BlockItem]
_finalItems  = [BlockItem]
forall a. Monoid a => a
mempty
    , _usedVars :: Set Id
_usedVars    = Set Id
forall a. Monoid a => a
mempty
    , _funUsedVars :: Map String (Set Id)
_funUsedVars = Map String (Set Id)
forall a. Monoid a => a
mempty
    }

-- | Code generation type constraints
type MonadC m = (Functor m, Applicative m, Monad m, MonadState CEnv m, MonadException m, MonadFix m)

-- | The C code generation monad transformer
newtype CGenT t a = CGenT { CGenT t a -> StateT CEnv (ExceptionT t) a
unCGenT :: StateT CEnv (ExceptionT t) a }
  deriving (a -> CGenT t b -> CGenT t a
(a -> b) -> CGenT t a -> CGenT t b
(forall a b. (a -> b) -> CGenT t a -> CGenT t b)
-> (forall a b. a -> CGenT t b -> CGenT t a) -> Functor (CGenT t)
forall a b. a -> CGenT t b -> CGenT t a
forall a b. (a -> b) -> CGenT t a -> CGenT t b
forall (t :: * -> *) a b. Functor t => a -> CGenT t b -> CGenT t a
forall (t :: * -> *) a b.
Functor t =>
(a -> b) -> CGenT t a -> CGenT t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CGenT t b -> CGenT t a
$c<$ :: forall (t :: * -> *) a b. Functor t => a -> CGenT t b -> CGenT t a
fmap :: (a -> b) -> CGenT t a -> CGenT t b
$cfmap :: forall (t :: * -> *) a b.
Functor t =>
(a -> b) -> CGenT t a -> CGenT t b
Functor, Functor (CGenT t)
a -> CGenT t a
Functor (CGenT t)
-> (forall a. a -> CGenT t a)
-> (forall a b. CGenT t (a -> b) -> CGenT t a -> CGenT t b)
-> (forall a b c.
    (a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c)
-> (forall a b. CGenT t a -> CGenT t b -> CGenT t b)
-> (forall a b. CGenT t a -> CGenT t b -> CGenT t a)
-> Applicative (CGenT t)
CGenT t a -> CGenT t b -> CGenT t b
CGenT t a -> CGenT t b -> CGenT t a
CGenT t (a -> b) -> CGenT t a -> CGenT t b
(a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c
forall a. a -> CGenT t a
forall a b. CGenT t a -> CGenT t b -> CGenT t a
forall a b. CGenT t a -> CGenT t b -> CGenT t b
forall a b. CGenT t (a -> b) -> CGenT t a -> CGenT t b
forall a b c. (a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c
forall (t :: * -> *). Monad t => Functor (CGenT t)
forall (t :: * -> *) a. Monad t => a -> CGenT t a
forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t a
forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t b
forall (t :: * -> *) a b.
Monad t =>
CGenT t (a -> b) -> CGenT t a -> CGenT t b
forall (t :: * -> *) a b c.
Monad t =>
(a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CGenT t a -> CGenT t b -> CGenT t a
$c<* :: forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t a
*> :: CGenT t a -> CGenT t b -> CGenT t b
$c*> :: forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t b
liftA2 :: (a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c
$cliftA2 :: forall (t :: * -> *) a b c.
Monad t =>
(a -> b -> c) -> CGenT t a -> CGenT t b -> CGenT t c
<*> :: CGenT t (a -> b) -> CGenT t a -> CGenT t b
$c<*> :: forall (t :: * -> *) a b.
Monad t =>
CGenT t (a -> b) -> CGenT t a -> CGenT t b
pure :: a -> CGenT t a
$cpure :: forall (t :: * -> *) a. Monad t => a -> CGenT t a
$cp1Applicative :: forall (t :: * -> *). Monad t => Functor (CGenT t)
Applicative, Applicative (CGenT t)
a -> CGenT t a
Applicative (CGenT t)
-> (forall a b. CGenT t a -> (a -> CGenT t b) -> CGenT t b)
-> (forall a b. CGenT t a -> CGenT t b -> CGenT t b)
-> (forall a. a -> CGenT t a)
-> Monad (CGenT t)
CGenT t a -> (a -> CGenT t b) -> CGenT t b
CGenT t a -> CGenT t b -> CGenT t b
forall a. a -> CGenT t a
forall a b. CGenT t a -> CGenT t b -> CGenT t b
forall a b. CGenT t a -> (a -> CGenT t b) -> CGenT t b
forall (t :: * -> *). Monad t => Applicative (CGenT t)
forall (t :: * -> *) a. Monad t => a -> CGenT t a
forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t b
forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> (a -> CGenT t b) -> CGenT t b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CGenT t a
$creturn :: forall (t :: * -> *) a. Monad t => a -> CGenT t a
>> :: CGenT t a -> CGenT t b -> CGenT t b
$c>> :: forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t b
>>= :: CGenT t a -> (a -> CGenT t b) -> CGenT t b
$c>>= :: forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> (a -> CGenT t b) -> CGenT t b
$cp1Monad :: forall (t :: * -> *). Monad t => Applicative (CGenT t)
Monad, Monad (CGenT t)
e -> CGenT t a
Monad (CGenT t)
-> (forall e a. Exception e => e -> CGenT t a)
-> (forall e a.
    Exception e =>
    CGenT t a -> (e -> CGenT t a) -> CGenT t a)
-> (forall a b. CGenT t a -> CGenT t b -> CGenT t a)
-> MonadException (CGenT t)
CGenT t a -> (e -> CGenT t a) -> CGenT t a
CGenT t a -> CGenT t b -> CGenT t a
forall e a. Exception e => e -> CGenT t a
forall e a.
Exception e =>
CGenT t a -> (e -> CGenT t a) -> CGenT t a
forall a b. CGenT t a -> CGenT t b -> CGenT t a
forall (t :: * -> *). Monad t => Monad (CGenT t)
forall (m :: * -> *).
Monad m
-> (forall e a. Exception e => e -> m a)
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> (forall a b. m a -> m b -> m a)
-> MonadException m
forall (t :: * -> *) e a. (Monad t, Exception e) => e -> CGenT t a
forall (t :: * -> *) e a.
(Monad t, Exception e) =>
CGenT t a -> (e -> CGenT t a) -> CGenT t a
forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t a
finally :: CGenT t a -> CGenT t b -> CGenT t a
$cfinally :: forall (t :: * -> *) a b.
Monad t =>
CGenT t a -> CGenT t b -> CGenT t a
catch :: CGenT t a -> (e -> CGenT t a) -> CGenT t a
$ccatch :: forall (t :: * -> *) e a.
(Monad t, Exception e) =>
CGenT t a -> (e -> CGenT t a) -> CGenT t a
throw :: e -> CGenT t a
$cthrow :: forall (t :: * -> *) e a. (Monad t, Exception e) => e -> CGenT t a
$cp1MonadException :: forall (t :: * -> *). Monad t => Monad (CGenT t)
MonadException, MonadState CEnv, Monad (CGenT t)
Monad (CGenT t)
-> (forall a. IO a -> CGenT t a) -> MonadIO (CGenT t)
IO a -> CGenT t a
forall a. IO a -> CGenT t a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (t :: * -> *). MonadIO t => Monad (CGenT t)
forall (t :: * -> *) a. MonadIO t => IO a -> CGenT t a
liftIO :: IO a -> CGenT t a
$cliftIO :: forall (t :: * -> *) a. MonadIO t => IO a -> CGenT t a
$cp1MonadIO :: forall (t :: * -> *). MonadIO t => Monad (CGenT t)
MonadIO, Monad (CGenT t)
Monad (CGenT t)
-> (forall a. (a -> CGenT t a) -> CGenT t a) -> MonadFix (CGenT t)
(a -> CGenT t a) -> CGenT t a
forall a. (a -> CGenT t a) -> CGenT t a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (t :: * -> *). MonadFix t => Monad (CGenT t)
forall (t :: * -> *) a. MonadFix t => (a -> CGenT t a) -> CGenT t a
mfix :: (a -> CGenT t a) -> CGenT t a
$cmfix :: forall (t :: * -> *) a. MonadFix t => (a -> CGenT t a) -> CGenT t a
$cp1MonadFix :: forall (t :: * -> *). MonadFix t => Monad (CGenT t)
MonadFix)

type CGen = CGenT Identity

-- | Run the C code generation monad
runCGenT :: Monad m => CGenT m a -> CEnv -> m (a, CEnv)
runCGenT :: CGenT m a -> CEnv -> m (a, CEnv)
runCGenT CGenT m a
m CEnv
s =
    (SomeException -> m (a, CEnv))
-> ((a, CEnv) -> m (a, CEnv))
-> Either SomeException (a, CEnv)
-> m (a, CEnv)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m (a, CEnv)
forall a. HasCallStack => String -> a
error (String -> m (a, CEnv))
-> (SomeException -> String) -> SomeException -> m (a, CEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) (a, CEnv) -> m (a, CEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException (a, CEnv) -> m (a, CEnv))
-> m (Either SomeException (a, CEnv)) -> m (a, CEnv)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptionT m (a, CEnv) -> m (Either SomeException (a, CEnv))
forall (m :: * -> *) a.
ExceptionT m a -> m (Either SomeException a)
runExceptionT (StateT CEnv (ExceptionT m) a -> CEnv -> ExceptionT m (a, CEnv)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (CGenT m a -> StateT CEnv (ExceptionT m) a
forall (t :: * -> *) a. CGenT t a -> StateT CEnv (ExceptionT t) a
unCGenT CGenT m a
m) CEnv
s)

-- | Run the C code generation monad
runCGen :: CGen a -> CEnv -> (a, CEnv)
runCGen :: CGen a -> CEnv -> (a, CEnv)
runCGen CGen a
m = Identity (a, CEnv) -> (a, CEnv)
forall a. Identity a -> a
runIdentity (Identity (a, CEnv) -> (a, CEnv))
-> (CEnv -> Identity (a, CEnv)) -> CEnv -> (a, CEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGen a -> CEnv -> Identity (a, CEnv)
forall (m :: * -> *) a. Monad m => CGenT m a -> CEnv -> m (a, CEnv)
runCGenT CGen a
m

-- | Extract a compilation unit from the 'CEnv' state
cenvToCUnit :: CEnv -> [C.Definition]
cenvToCUnit :: CEnv -> [Definition]
cenvToCUnit CEnv
env =
    [cunit|$edecls:incs
           $edecls:tds
           $edecls:protos
           $edecls:globs|]
  where
    incs :: [Definition]
incs = (String -> Definition) -> [String] -> [Definition]
forall a b. (a -> b) -> [a] -> [b]
map String -> Definition
toInclude (Set String -> [String]
forall a. Set a -> [a]
Set.toList (CEnv -> Set String
_includes CEnv
env))
      where
        toInclude :: String -> C.Definition
        toInclude :: String -> Definition
toInclude String
inc = [cedecl|$esc:include|]
          where include :: String
include = String
"#include " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inc
    tds :: [Definition]
tds    = [Definition] -> [Definition]
forall a. Eq a => [a] -> [a]
nub ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ [Definition] -> [Definition]
forall a. [a] -> [a]
reverse ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ CEnv -> [Definition]
_typedefs CEnv
env
    protos :: [Definition]
protos = [Definition] -> [Definition]
forall a. Eq a => [a] -> [a]
nub ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ [Definition] -> [Definition]
forall a. [a] -> [a]
reverse ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ CEnv -> [Definition]
_prototypes CEnv
env
    globs :: [Definition]
globs  = [Definition] -> [Definition]
forall a. Eq a => [a] -> [a]
nub ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ [Definition] -> [Definition]
forall a. [a] -> [a]
reverse ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ CEnv -> [Definition]
_globals CEnv
env

-- | Generate C documents for each module
prettyCGenT :: Monad m => CGenT m a -> m [(String, Doc)]
prettyCGenT :: CGenT m a -> m [(String, Doc)]
prettyCGenT CGenT m a
ma = do
    (a
_,CEnv
cenv) <- CGenT m a -> CEnv -> m (a, CEnv)
forall (m :: * -> *) a. Monad m => CGenT m a -> CEnv -> m (a, CEnv)
runCGenT CGenT m a
ma (Flags -> CEnv
defaultCEnv Flags
Flags)
    [(String, Doc)] -> m [(String, Doc)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Doc)] -> m [(String, Doc)])
-> [(String, Doc)] -> m [(String, Doc)]
forall a b. (a -> b) -> a -> b
$ ((String, [Definition]) -> (String, Doc))
-> [(String, [Definition])] -> [(String, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"", [Definition] -> Doc
forall a. Pretty a => a -> Doc
ppr) (String, [Definition] -> Doc)
-> (String, [Definition]) -> (String, Doc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>)
           ([(String, [Definition])] -> [(String, Doc)])
-> [(String, [Definition])] -> [(String, Doc)]
forall a b. (a -> b) -> a -> b
$ (String
"main", CEnv -> [Definition]
cenvToCUnit CEnv
cenv) (String, [Definition])
-> [(String, [Definition])] -> [(String, [Definition])]
forall a. a -> [a] -> [a]
: Map String [Definition] -> [(String, [Definition])]
forall k a. Map k a -> [(k, a)]
Map.toList (CEnv -> Map String [Definition]
_modules CEnv
cenv)

prettyCGen :: CGen a -> [(String, Doc)]
prettyCGen :: CGen a -> [(String, Doc)]
prettyCGen = Identity [(String, Doc)] -> [(String, Doc)]
forall a. Identity a -> a
runIdentity (Identity [(String, Doc)] -> [(String, Doc)])
-> (CGen a -> Identity [(String, Doc)])
-> CGen a
-> [(String, Doc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGen a -> Identity [(String, Doc)]
forall (m :: * -> *) a. Monad m => CGenT m a -> m [(String, Doc)]
prettyCGenT

-- | Retrieve a fresh identifier
freshId :: MonadC m => m Integer
freshId :: m Integer
freshId = (Integer -> (Integer, Integer)) -> CEnv -> (Integer, CEnv)
Lens' CEnv Integer
unique ((Integer -> (Integer, Integer)) -> CEnv -> (Integer, CEnv))
-> (Integer -> Integer) -> m Integer
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> (a -> b) -> m a
<<%= Integer -> Integer
forall a. Enum a => a -> a
succ

-- | Generate a fresh symbol by appending a fresh id to a base name
gensym :: MonadC m => String -> m String
gensym :: String -> m String
gensym String
s = do
    Integer
u <- m Integer
forall (m :: * -> *). MonadC m => m Integer
freshId
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
u

-- | Mark an identifier as used in this context.
touchVar :: (MonadC m, ToIdent v) => v -> m ()
touchVar :: v -> m ()
touchVar v
v = (Set Id -> Identity (Set Id)) -> CEnv -> Identity CEnv
Lens' CEnv (Set Id)
usedVars ((Set Id -> Identity (Set Id)) -> CEnv -> Identity CEnv)
-> (Set Id -> Set Id) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Id -> Set Id -> Set Id
forall a. Ord a => a -> Set a -> Set a
Set.insert (v -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
toIdent v
v (Loc -> SrcLoc
SrcLoc Loc
NoLoc))

-- | Set the 'Set' of identifers used in the body of the given function.
setUsedVars :: MonadC m => String -> Set.Set C.Id -> m ()
setUsedVars :: String -> Set Id -> m ()
setUsedVars String
fun Set Id
uvs = (Map String (Set Id) -> Identity (Map String (Set Id)))
-> CEnv -> Identity CEnv
Lens' CEnv (Map String (Set Id))
funUsedVars ((Map String (Set Id) -> Identity (Map String (Set Id)))
 -> CEnv -> Identity CEnv)
-> (Map String (Set Id) -> Map String (Set Id)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= String -> Set Id -> Map String (Set Id) -> Map String (Set Id)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
fun Set Id
uvs

-- | Add an include pre-processor directive. Specify '<>' or '""' around
-- the file name.
addInclude :: MonadC m => String -> m ()
addInclude :: String -> m ()
addInclude String
inc = (Set String -> Identity (Set String)) -> CEnv -> Identity CEnv
Lens' CEnv (Set String)
includes ((Set String -> Identity (Set String)) -> CEnv -> Identity CEnv)
-> (Set String -> Set String) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
inc

-- | Add a local include directive. The argument will be surrounded by '""'
addLocalInclude :: MonadC m => String -> m ()
addLocalInclude :: String -> m ()
addLocalInclude String
inc = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude (String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")

-- | Add a system include directive. The argument will be surrounded by '<>'
addSystemInclude :: MonadC m => String -> m ()
addSystemInclude :: String -> m ()
addSystemInclude String
inc = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude (String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">")

-- | Add a type definition
addTypedef :: MonadC m => C.Definition -> m ()
addTypedef :: Definition -> m ()
addTypedef Definition
def = ([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv
Lens' CEnv [Definition]
typedefs (([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv)
-> ([Definition] -> [Definition]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Definition
defDefinition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
:)

-- | Add a function prototype
addPrototype :: MonadC m => C.Definition -> m ()
addPrototype :: Definition -> m ()
addPrototype Definition
def = ([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv
Lens' CEnv [Definition]
prototypes (([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv)
-> ([Definition] -> [Definition]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Definition
defDefinition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
:)

-- | Add a global definition
addGlobal :: MonadC m => C.Definition -> m ()
addGlobal :: Definition -> m ()
addGlobal Definition
def = ([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv
Lens' CEnv [Definition]
globals (([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv)
-> ([Definition] -> [Definition]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Definition
defDefinition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
:)

-- | Add multiple global definitions
addGlobals :: MonadC m => [C.Definition] -> m ()
addGlobals :: [Definition] -> m ()
addGlobals [Definition]
defs = ([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv
Lens' CEnv [Definition]
globals (([Definition] -> Identity [Definition]) -> CEnv -> Identity CEnv)
-> ([Definition] -> [Definition]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Definition]
defs[Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++)

-- | Let a variable be known by another name
withAlias :: MonadC m => Integer -> String -> m a -> m a
withAlias :: Integer -> String -> m a -> m a
withAlias Integer
i String
n m a
act = do
  Map Integer String
oldAliases <- (Map Integer String -> (Map Integer String, Map Integer String))
-> CEnv -> (Map Integer String, CEnv)
Lens' CEnv (Map Integer String)
aliases ((Map Integer String -> (Map Integer String, Map Integer String))
 -> CEnv -> (Map Integer String, CEnv))
-> (Map Integer String -> Map Integer String)
-> m (Map Integer String)
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> (a -> b) -> m a
<<%= Integer -> String -> Map Integer String -> Map Integer String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Integer
i String
n
  a
a <- m a
act
  (Map Integer String -> Identity (Map Integer String))
-> CEnv -> Identity CEnv
Lens' CEnv (Map Integer String)
aliases ((Map Integer String -> Identity (Map Integer String))
 -> CEnv -> Identity CEnv)
-> Map Integer String -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Map Integer String
oldAliases
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Add a function parameter when building a function definition
addParam :: MonadC m => C.Param -> m ()
addParam :: Param -> m ()
addParam Param
param = ([Param] -> Identity [Param]) -> CEnv -> Identity CEnv
Lens' CEnv [Param]
params (([Param] -> Identity [Param]) -> CEnv -> Identity CEnv)
-> ([Param] -> [Param]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Param
paramParam -> [Param] -> [Param]
forall a. a -> [a] -> [a]
:)

addParams :: MonadC m => [C.Param] -> m ()
addParams :: [Param] -> m ()
addParams [Param]
ps = ([Param] -> Identity [Param]) -> CEnv -> Identity CEnv
Lens' CEnv [Param]
params (([Param] -> Identity [Param]) -> CEnv -> Identity CEnv)
-> ([Param] -> [Param]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Param] -> [Param]
forall a. [a] -> [a]
reverse [Param]
ps[Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++)

-- | Add a function argument when building a function call
addArg :: MonadC m => C.Exp -> m ()
addArg :: Exp -> m ()
addArg Exp
arg = ([Exp] -> Identity [Exp]) -> CEnv -> Identity CEnv
Lens' CEnv [Exp]
args (([Exp] -> Identity [Exp]) -> CEnv -> Identity CEnv)
-> ([Exp] -> [Exp]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Exp
argExp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:)

-- | Add a local declaration (including initializations)
addLocal :: MonadC m => C.InitGroup -> m ()
addLocal :: InitGroup -> m ()
addLocal InitGroup
def = do
  ([InitGroup] -> Identity [InitGroup]) -> CEnv -> Identity CEnv
Lens' CEnv [InitGroup]
locals (([InitGroup] -> Identity [InitGroup]) -> CEnv -> Identity CEnv)
-> ([InitGroup] -> [InitGroup]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (InitGroup
defInitGroup -> [InitGroup] -> [InitGroup]
forall a. a -> [a] -> [a]
:)
  case InitGroup
def of
    C.InitGroup DeclSpec
_ [Attr]
_ [Init]
is SrcLoc
_ -> [Init] -> (Init -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Init]
is ((Init -> m ()) -> m ()) -> (Init -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(C.Init Id
id Decl
_ Maybe AsmLabel
_ Maybe Initializer
_ [Attr]
_ SrcLoc
_) -> Id -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar Id
id
    InitGroup
_                    -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add an item (a declaration or a statement) to the current block
--   This functionality is necessary to declare C99 variable-length arrays
--   in the middle of a block, as other local delcarations are lifted to the
--   beginning of the block, and that makes the evaluation of the length
--   expression impossible.
addItem :: MonadC m => C.BlockItem -> m ()
addItem :: BlockItem -> m ()
addItem BlockItem
item = ([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv
Lens' CEnv [BlockItem]
items (([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv)
-> ([BlockItem] -> [BlockItem]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (BlockItem
itemBlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
:)

-- | Add multiple local declarations
addLocals :: MonadC m => [C.InitGroup] -> m ()
addLocals :: [InitGroup] -> m ()
addLocals [InitGroup]
defs = (InitGroup -> m ()) -> [InitGroup] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InitGroup -> m ()
forall (m :: * -> *). MonadC m => InitGroup -> m ()
addLocal [InitGroup]
defs -- locals %= (reverse defs++)

-- | Add a statement to the current block
addStm :: MonadC m => C.Stm -> m ()
addStm :: Stm -> m ()
addStm Stm
stm = ([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv
Lens' CEnv [BlockItem]
items (([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv)
-> ([BlockItem] -> [BlockItem]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Stm -> BlockItem
C.BlockStm Stm
stm)BlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
:)

-- | Add a sequence of statements to the current block
addStms :: MonadC m => [C.Stm] -> m ()
addStms :: [Stm] -> m ()
addStms [Stm]
ss = ([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv
Lens' CEnv [BlockItem]
items (([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv)
-> ([BlockItem] -> [BlockItem]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([BlockItem] -> [BlockItem]
forall a. [a] -> [a]
reverse ((Stm -> BlockItem) -> [Stm] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map Stm -> BlockItem
C.BlockStm [Stm]
ss)[BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++)

-- | Add a statement to the end of the current block
addFinalStm :: MonadC m => C.Stm -> m ()
addFinalStm :: Stm -> m ()
addFinalStm Stm
stm = ([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv
Lens' CEnv [BlockItem]
finalItems (([BlockItem] -> Identity [BlockItem]) -> CEnv -> Identity CEnv)
-> ([BlockItem] -> [BlockItem]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Stm -> BlockItem
C.BlockStm Stm
stm)BlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
:)

-- | Run an action in a new block
inBlock :: MonadC m => m a -> m a
inBlock :: m a -> m a
inBlock m a
ma = do
    (a
a, [BlockItem]
items) <- m a -> m (a, [BlockItem])
forall (m :: * -> *) a. MonadC m => m a -> m (a, [BlockItem])
inNewBlock m a
ma
    Stm -> m ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm|{ $items:items }|]
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Run an action as a block and capture the items.
-- Does not place the items in an actual C block.
inNewBlock :: MonadC m => m a -> m (a, [C.BlockItem])
inNewBlock :: m a -> m (a, [BlockItem])
inNewBlock m a
ma = do
    [InitGroup]
oldLocals     <- ([InitGroup] -> ([InitGroup], [InitGroup]))
-> CEnv -> ([InitGroup], CEnv)
Lens' CEnv [InitGroup]
locals     (([InitGroup] -> ([InitGroup], [InitGroup]))
 -> CEnv -> ([InitGroup], CEnv))
-> [InitGroup] -> m [InitGroup]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [InitGroup]
forall a. Monoid a => a
mempty
    [BlockItem]
oldItems      <- ([BlockItem] -> ([BlockItem], [BlockItem]))
-> CEnv -> ([BlockItem], CEnv)
Lens' CEnv [BlockItem]
items      (([BlockItem] -> ([BlockItem], [BlockItem]))
 -> CEnv -> ([BlockItem], CEnv))
-> [BlockItem] -> m [BlockItem]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [BlockItem]
forall a. Monoid a => a
mempty
    [BlockItem]
oldFinalItems <- ([BlockItem] -> ([BlockItem], [BlockItem]))
-> CEnv -> ([BlockItem], CEnv)
Lens' CEnv [BlockItem]
finalItems (([BlockItem] -> ([BlockItem], [BlockItem]))
 -> CEnv -> ([BlockItem], CEnv))
-> [BlockItem] -> m [BlockItem]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [BlockItem]
forall a. Monoid a => a
mempty
    a
x <- m a
ma
    [InitGroup]
ls  <- [InitGroup] -> [InitGroup]
forall a. [a] -> [a]
reverse ([InitGroup] -> [InitGroup]) -> m [InitGroup] -> m [InitGroup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([InitGroup] -> ([InitGroup], [InitGroup]))
-> CEnv -> ([InitGroup], CEnv)
Lens' CEnv [InitGroup]
locals     (([InitGroup] -> ([InitGroup], [InitGroup]))
 -> CEnv -> ([InitGroup], CEnv))
-> [InitGroup] -> m [InitGroup]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [InitGroup]
oldLocals)
    [BlockItem]
ss  <- [BlockItem] -> [BlockItem]
forall a. [a] -> [a]
reverse ([BlockItem] -> [BlockItem]) -> m [BlockItem] -> m [BlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([BlockItem] -> ([BlockItem], [BlockItem]))
-> CEnv -> ([BlockItem], CEnv)
Lens' CEnv [BlockItem]
items      (([BlockItem] -> ([BlockItem], [BlockItem]))
 -> CEnv -> ([BlockItem], CEnv))
-> [BlockItem] -> m [BlockItem]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [BlockItem]
oldItems)
    [BlockItem]
fss <- [BlockItem] -> [BlockItem]
forall a. [a] -> [a]
reverse ([BlockItem] -> [BlockItem]) -> m [BlockItem] -> m [BlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([BlockItem] -> ([BlockItem], [BlockItem]))
-> CEnv -> ([BlockItem], CEnv)
Lens' CEnv [BlockItem]
finalItems (([BlockItem] -> ([BlockItem], [BlockItem]))
 -> CEnv -> ([BlockItem], CEnv))
-> [BlockItem] -> m [BlockItem]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [BlockItem]
oldFinalItems)
    (a, [BlockItem]) -> m (a, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, (InitGroup -> BlockItem) -> [InitGroup] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map InitGroup -> BlockItem
C.BlockDecl [InitGroup]
ls  [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
               [BlockItem]
ss  [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++
               [BlockItem]
fss
           )

-- | Run an action as a block and capture the items.
-- Does not place the items in an actual C block.
inNewBlock_ :: MonadC m => m a -> m [C.BlockItem]
inNewBlock_ :: m a -> m [BlockItem]
inNewBlock_ m a
ma = (a, [BlockItem]) -> [BlockItem]
forall a b. (a, b) -> b
snd ((a, [BlockItem]) -> [BlockItem])
-> m (a, [BlockItem]) -> m [BlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m (a, [BlockItem])
forall (m :: * -> *) a. MonadC m => m a -> m (a, [BlockItem])
inNewBlock m a
ma

-- | Run an action as a function declaration.
-- Does not create a new function.
inNewFunction :: MonadC m => m a -> m (a,Set.Set C.Id,[C.Param],[C.BlockItem])
inNewFunction :: m a -> m (a, Set Id, [Param], [BlockItem])
inNewFunction m a
comp = do
    [Param]
oldParams <- ([Param] -> ([Param], [Param])) -> CEnv -> ([Param], CEnv)
Lens' CEnv [Param]
params (([Param] -> ([Param], [Param])) -> CEnv -> ([Param], CEnv))
-> [Param] -> m [Param]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Param]
forall a. Monoid a => a
mempty
    Set Id
oldUsedVars <- (Set Id -> (Set Id, Set Id)) -> CEnv -> (Set Id, CEnv)
Lens' CEnv (Set Id)
usedVars ((Set Id -> (Set Id, Set Id)) -> CEnv -> (Set Id, CEnv))
-> Set Id -> m (Set Id)
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= Set Id
forall a. Monoid a => a
mempty
    (a
a,[BlockItem]
items)  <- m a -> m (a, [BlockItem])
forall (m :: * -> *) a. MonadC m => m a -> m (a, [BlockItem])
inNewBlock m a
comp
    [Param]
ps <- ([Param] -> ([Param], [Param])) -> CEnv -> ([Param], CEnv)
Lens' CEnv [Param]
params (([Param] -> ([Param], [Param])) -> CEnv -> ([Param], CEnv))
-> [Param] -> m [Param]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Param]
oldParams
    Set Id
uvs <- (Set Id -> (Set Id, Set Id)) -> CEnv -> (Set Id, CEnv)
Lens' CEnv (Set Id)
usedVars ((Set Id -> (Set Id, Set Id)) -> CEnv -> (Set Id, CEnv))
-> Set Id -> m (Set Id)
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= Set Id
oldUsedVars
    (a, Set Id, [Param], [BlockItem])
-> m (a, Set Id, [Param], [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Set Id
uvs, [Param] -> [Param]
forall a. [a] -> [a]
reverse [Param]
ps, [BlockItem]
items)

-- | Declare a function
inFunction :: MonadC m => String -> m a -> m a
inFunction :: String -> m a -> m a
inFunction = Type -> String -> m a -> m a
forall (m :: * -> *) a. MonadC m => Type -> String -> m a -> m a
inFunctionTy [cty|void|]

-- | Declare a function with the given return type.
inFunctionTy :: MonadC m => C.Type -> String -> m a -> m a
inFunctionTy :: Type -> String -> m a -> m a
inFunctionTy Type
ty String
fun m a
ma = do
    (a
a,Set Id
uvs,[Param]
ps,[BlockItem]
items) <- m a -> m (a, Set Id, [Param], [BlockItem])
forall (m :: * -> *) a.
MonadC m =>
m a -> m (a, Set Id, [Param], [BlockItem])
inNewFunction m a
ma
    String -> Set Id -> m ()
forall (m :: * -> *). MonadC m => String -> Set Id -> m ()
setUsedVars String
fun Set Id
uvs
    Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addPrototype [cedecl| $ty:ty $id:fun($params:ps);|]
    Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal [cedecl| $ty:ty $id:fun($params:ps){ $items:items }|]
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Collect all global definitions in the current state
collectDefinitions :: MonadC m => m a -> m (a, [C.Definition])
collectDefinitions :: m a -> m (a, [Definition])
collectDefinitions m a
ma = do
    Set String
oldIncludes   <- (Set String -> (Set String, Set String))
-> CEnv -> (Set String, CEnv)
Lens' CEnv (Set String)
includes   ((Set String -> (Set String, Set String))
 -> CEnv -> (Set String, CEnv))
-> Set String -> m (Set String)
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= Set String
forall a. Monoid a => a
mempty
    [Definition]
oldTypedefs   <- ([Definition] -> ([Definition], [Definition]))
-> CEnv -> ([Definition], CEnv)
Lens' CEnv [Definition]
typedefs   (([Definition] -> ([Definition], [Definition]))
 -> CEnv -> ([Definition], CEnv))
-> [Definition] -> m [Definition]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Definition]
forall a. Monoid a => a
mempty
    [Definition]
oldPrototypes <- ([Definition] -> ([Definition], [Definition]))
-> CEnv -> ([Definition], CEnv)
Lens' CEnv [Definition]
prototypes (([Definition] -> ([Definition], [Definition]))
 -> CEnv -> ([Definition], CEnv))
-> [Definition] -> m [Definition]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Definition]
forall a. Monoid a => a
mempty
    [Definition]
oldGlobals    <- ([Definition] -> ([Definition], [Definition]))
-> CEnv -> ([Definition], CEnv)
Lens' CEnv [Definition]
globals    (([Definition] -> ([Definition], [Definition]))
 -> CEnv -> ([Definition], CEnv))
-> [Definition] -> m [Definition]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Definition]
forall a. Monoid a => a
mempty
    a
a  <- m a
ma
    CEnv
s' <- m CEnv
forall s (m :: * -> *). MonadState s m => m s
get
    (CEnv -> CEnv) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CEnv -> CEnv) -> m ()) -> (CEnv -> CEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \CEnv
s -> CEnv
s { _includes :: Set String
_includes   = Set String
oldIncludes    -- <> _includes s'
                     , _typedefs :: [Definition]
_typedefs   = [Definition]
oldTypedefs    -- <> _typedefs s'
                     , _prototypes :: [Definition]
_prototypes = [Definition]
oldPrototypes  -- <> _prototypes s'
                     , _globals :: [Definition]
_globals    = [Definition]
oldGlobals     -- <> _globals s'
                     }
    (a, [Definition]) -> m (a, [Definition])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CEnv -> [Definition]
cenvToCUnit CEnv
s')

-- | Collect all function arguments in the current state
collectArgs :: MonadC m => m [C.Exp]
collectArgs :: m [Exp]
collectArgs = ([Exp] -> ([Exp], [Exp])) -> CEnv -> ([Exp], CEnv)
Lens' CEnv [Exp]
args (([Exp] -> ([Exp], [Exp])) -> CEnv -> ([Exp], CEnv))
-> [Exp] -> m [Exp]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= [Exp]
forall a. Monoid a => a
mempty

-- | Declare a C translation unit
inModule :: MonadC m => String -> m a -> m a
inModule :: String -> m a -> m a
inModule String
name m a
prg = do
    Integer
oldUnique <- (Integer -> (Integer, Integer)) -> CEnv -> (Integer, CEnv)
Lens' CEnv Integer
unique ((Integer -> (Integer, Integer)) -> CEnv -> (Integer, CEnv))
-> Integer -> m Integer
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= Integer
0
    (a
a, [Definition]
defs) <- m a -> m (a, [Definition])
forall (m :: * -> *) a. MonadC m => m a -> m (a, [Definition])
collectDefinitions m a
prg
    (Integer -> Identity Integer) -> CEnv -> Identity CEnv
Lens' CEnv Integer
unique ((Integer -> Identity Integer) -> CEnv -> Identity CEnv)
-> Integer -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Integer
oldUnique
    (Map String [Definition] -> Identity (Map String [Definition]))
-> CEnv -> Identity CEnv
Lens' CEnv (Map String [Definition])
modules ((Map String [Definition] -> Identity (Map String [Definition]))
 -> CEnv -> Identity CEnv)
-> (Map String [Definition] -> Map String [Definition]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Definition] -> [Definition] -> [Definition])
-> String
-> [Definition]
-> Map String [Definition]
-> Map String [Definition]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Definition] -> [Definition] -> [Definition]
forall a. Semigroup a => a -> a -> a
(<>) String
name [Definition]
defs
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Wrap a program in a main function
wrapMain :: MonadC m => m a -> m ()
wrapMain :: m a -> m ()
wrapMain m a
prog = do
    (()
_,Set Id
uvs,[Param]
params,[BlockItem]
items) <- m () -> m ((), Set Id, [Param], [BlockItem])
forall (m :: * -> *) a.
MonadC m =>
m a -> m (a, Set Id, [Param], [BlockItem])
inNewFunction (m () -> m ((), Set Id, [Param], [BlockItem]))
-> m () -> m ((), Set Id, [Param], [BlockItem])
forall a b. (a -> b) -> a -> b
$ m a
prog m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stm -> m ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| return 0; |]
    String -> Set Id -> m ()
forall (m :: * -> *). MonadC m => String -> Set Id -> m ()
setUsedVars String
"main" Set Id
uvs
    Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal [cedecl| int main($params:params){ $items:items }|]

-- | Lift the declarations of all variables that are shared between functions
--   to the top level. This relies on variable IDs being unique across
--   programs, not just across the functions in which they are declared.
--
--   Only affects locally declared vars, not function arguments.
liftSharedLocals :: MonadC m => m a -> m ()
liftSharedLocals :: m a -> m ()
liftSharedLocals m a
prog = do
    m a
prog
    Set Id
uvs <- [Set Id] -> Set Id
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Id] -> Set Id) -> (CEnv -> [Set Id]) -> CEnv -> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Set Id) -> [Set Id]
forall k a. Map k a -> [a]
Map.elems (Map String (Set Id) -> [Set Id])
-> (CEnv -> Map String (Set Id)) -> CEnv -> [Set Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Set Id) -> Map String (Set Id)
onlyShared (Map String (Set Id) -> Map String (Set Id))
-> (CEnv -> Map String (Set Id)) -> CEnv -> Map String (Set Id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CEnv -> Map String (Set Id)
_funUsedVars (CEnv -> Set Id) -> m CEnv -> m (Set Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m CEnv
forall s (m :: * -> *). MonadState s m => m s
get
    -- This could be more efficient by just filtering each function for the
    -- vars we *know* are in there, provided that we had a Map from function
    -- names to bodies.
    [Definition]
oldglobs <- CEnv -> [Definition]
_globals (CEnv -> [Definition]) -> m CEnv -> m [Definition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m CEnv
forall s (m :: * -> *). MonadState s m => m s
get
    let ([Definition]
globs, [Set InitGroup]
shared) = [(Definition, Set InitGroup)] -> ([Definition], [Set InitGroup])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Definition, Set InitGroup)] -> ([Definition], [Set InitGroup]))
-> [(Definition, Set InitGroup)] -> ([Definition], [Set InitGroup])
forall a b. (a -> b) -> a -> b
$ (Definition -> (Definition, Set InitGroup))
-> [Definition] -> [(Definition, Set InitGroup)]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Bool) -> Definition -> (Definition, Set InitGroup)
extractDecls (Id -> Set Id -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Id
uvs)) [Definition]
oldglobs
        sharedList :: [InitGroup]
sharedList = Set InitGroup -> [InitGroup]
forall a. Set a -> [a]
Set.toList (Set InitGroup -> [InitGroup]) -> Set InitGroup -> [InitGroup]
forall a b. (a -> b) -> a -> b
$ [Set InitGroup] -> Set InitGroup
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set InitGroup]
shared
        sharedDecls :: [Definition]
sharedDecls = (InitGroup -> Definition) -> [InitGroup] -> [Definition]
forall a b. (a -> b) -> [a] -> [b]
map (\InitGroup
ig -> InitGroup -> SrcLoc -> Definition
C.DecDef InitGroup
ig (Loc -> SrcLoc
SrcLoc Loc
NoLoc)) [InitGroup]
sharedList
    -- Reverse is a trick that ensures the correct order of declarations for arrays
    -- and their wrapper pointers. It depends on the naming schema of identifiers:
    -- arrays are prefixed with underscores, while their wrappers are not.
    m [Definition] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [Definition] -> m ()) -> m [Definition] -> m ()
forall a b. (a -> b) -> a -> b
$ ([Definition] -> ([Definition], [Definition]))
-> CEnv -> ([Definition], CEnv)
Lens' CEnv [Definition]
globals (([Definition] -> ([Definition], [Definition]))
 -> CEnv -> ([Definition], CEnv))
-> [Definition] -> m [Definition]
forall s (m :: * -> *) a b.
MonadState s m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= ([Definition]
globs [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition] -> [Definition]
forall a. [a] -> [a]
reverse [Definition]
sharedDecls)
  where
    -- Only keep vars shared between functions by intersecting with the union
    -- of all other funs' uvs. TODO: optimize.
    onlyShared :: Map.Map String (Set.Set C.Id) -> Map.Map String (Set.Set C.Id)
    onlyShared :: Map String (Set Id) -> Map String (Set Id)
onlyShared Map String (Set Id)
alluvs =
        (String -> Set Id -> Set Id)
-> Map String (Set Id) -> Map String (Set Id)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey String -> Set Id -> Set Id
funUVSIntersects Map String (Set Id)
alluvs
      where
        funUVSIntersects :: String -> Set Id -> Set Id
funUVSIntersects String
fun Set Id
uvs =
          Set Id -> Set Id -> Set Id
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Id
uvs (Set Id -> Set Id) -> Set Id -> Set Id
forall a b. (a -> b) -> a -> b
$ [Set Id] -> Set Id
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Id] -> Set Id) -> [Set Id] -> Set Id
forall a b. (a -> b) -> a -> b
$ Map String (Set Id) -> [Set Id]
forall k a. Map k a -> [a]
Map.elems (Map String (Set Id) -> [Set Id])
-> Map String (Set Id) -> [Set Id]
forall a b. (a -> b) -> a -> b
$ String -> Map String (Set Id) -> Map String (Set Id)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
fun Map String (Set Id)
alluvs

-- | Remove all declarations matching a predicate from the given function
--   and return them in a separate list.
extractDecls :: (C.Id -> Bool)
             -> C.Definition
             -> (C.Definition, Set.Set C.InitGroup)
extractDecls :: (Id -> Bool) -> Definition -> (Definition, Set InitGroup)
extractDecls Id -> Bool
pred (C.FuncDef (C.Func DeclSpec
ds Id
id Decl
decl Params
params [BlockItem]
bis SrcLoc
loc') SrcLoc
loc) =
  case (BlockItem
 -> ([BlockItem], Set InitGroup) -> ([BlockItem], Set InitGroup))
-> ([BlockItem], Set InitGroup)
-> [BlockItem]
-> ([BlockItem], Set InitGroup)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockItem
-> ([BlockItem], Set InitGroup) -> ([BlockItem], Set InitGroup)
perBI ([], Set InitGroup
forall a. Set a
Set.empty) [BlockItem]
bis of
    ([BlockItem]
bis', Set InitGroup
igs) -> (Func -> SrcLoc -> Definition
C.FuncDef (DeclSpec -> Id -> Decl -> Params -> [BlockItem] -> SrcLoc -> Func
C.Func DeclSpec
ds Id
id Decl
decl Params
params [BlockItem]
bis' SrcLoc
loc') SrcLoc
loc, Set InitGroup
igs)
  where
    perBI :: BlockItem
-> ([BlockItem], Set InitGroup) -> ([BlockItem], Set InitGroup)
perBI decl :: BlockItem
decl@(C.BlockDecl ig :: InitGroup
ig@(C.InitGroup DeclSpec
ds [Attr]
attrs [Init]
is SrcLoc
loc)) ([BlockItem]
bis, Set InitGroup
igs) =
      case (Init -> Bool) -> [Init] -> ([Init], [Init])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(C.Init Id
id Decl
_ Maybe AsmLabel
_ Maybe Initializer
_ [Attr]
_ SrcLoc
_) -> Id -> Bool
pred Id
id) [Init]
is of
        ([], [Init]
unmach) ->
          (BlockItem
decl BlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
: [BlockItem]
bis, Set InitGroup
igs)
        ([Init]
match, []) ->
          ([BlockItem]
bis, InitGroup -> Set InitGroup -> Set InitGroup
forall a. Ord a => a -> Set a -> Set a
Set.insert InitGroup
ig Set InitGroup
igs)
        ([Init]
match, [Init]
unmatch) ->
          (InitGroup -> BlockItem
C.BlockDecl (DeclSpec -> [Attr] -> [Init] -> SrcLoc -> InitGroup
C.InitGroup DeclSpec
ds [Attr]
attrs [Init]
unmatch SrcLoc
loc) BlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
: [BlockItem]
bis,
           InitGroup -> Set InitGroup -> Set InitGroup
forall a. Ord a => a -> Set a -> Set a
Set.insert (DeclSpec -> [Attr] -> [Init] -> SrcLoc -> InitGroup
C.InitGroup DeclSpec
ds [Attr]
attrs [Init]
match SrcLoc
loc) Set InitGroup
igs)
    perBI BlockItem
bi ([BlockItem]
bis, Set InitGroup
igs) =
      (BlockItem
biBlockItem -> [BlockItem] -> [BlockItem]
forall a. a -> [a] -> [a]
:[BlockItem]
bis, Set InitGroup
igs)
extractDecls Id -> Bool
_ Definition
decl =
  (Definition
decl, Set InitGroup
forall a. Set a
Set.empty)