-- | Partially evaluate all modules away from a source Futhark
-- program.  This is implemented as a source-to-source transformation.
module Futhark.Internalise.Defunctorise (transformProg) where

import Control.Monad.Identity
import Control.Monad.RWS.Strict
import Data.DList qualified as DL
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Futhark.MonadFreshNames
import Language.Futhark
import Language.Futhark.Semantic (FileModule (..), Imports, includeToString)
import Language.Futhark.Traversals
import Prelude hiding (abs, mod)

-- | A substitution from names in the original program to names in the
-- generated/residual program.
type Substitutions = M.Map VName VName

lookupSubst :: VName -> Substitutions -> VName
lookupSubst :: VName -> Substitutions -> VName
lookupSubst VName
v Substitutions
substs = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v Substitutions
substs of
  Just VName
v' | VName
v' forall a. Eq a => a -> a -> Bool
/= VName
v -> VName -> Substitutions -> VName
lookupSubst VName
v' Substitutions
substs
  Maybe VName
_ -> VName
v

data Mod
  = -- | A pairing of a lexical closure and a module function.
    ModFun TySet Scope ModParam ModExp
  | -- | A non-parametric module.
    ModMod Scope
  deriving (Int -> Mod -> ShowS
[Mod] -> ShowS
Mod -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Mod] -> ShowS
$cshowList :: [Mod] -> ShowS
show :: Mod -> [Char]
$cshow :: Mod -> [Char]
showsPrec :: Int -> Mod -> ShowS
$cshowsPrec :: Int -> Mod -> ShowS
Show)

modScope :: Mod -> Scope
modScope :: Mod -> Scope
modScope (ModMod Scope
scope) = Scope
scope
modScope ModFun {} = forall a. Monoid a => a
mempty

data Scope = Scope
  { Scope -> Substitutions
scopeSubsts :: Substitutions,
    Scope -> Map VName Mod
scopeMods :: M.Map VName Mod
  }
  deriving (Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Scope] -> ShowS
$cshowList :: [Scope] -> ShowS
show :: Scope -> [Char]
$cshow :: Scope -> [Char]
showsPrec :: Int -> Scope -> ShowS
$cshowsPrec :: Int -> Scope -> ShowS
Show)

lookupSubstInScope :: QualName VName -> Scope -> (QualName VName, Scope)
lookupSubstInScope :: QualName VName -> Scope -> (QualName VName, Scope)
lookupSubstInScope qn :: QualName VName
qn@(QualName [VName]
quals VName
name) scope :: Scope
scope@(Scope Substitutions
substs Map VName Mod
mods) =
  case [VName]
quals of
    [] -> (forall v. v -> QualName v
qualName forall a b. (a -> b) -> a -> b
$ VName -> Substitutions -> VName
lookupSubst VName
name Substitutions
substs, Scope
scope)
    VName
q : [VName]
qs ->
      let q' :: VName
q' = VName -> Substitutions -> VName
lookupSubst VName
q Substitutions
substs
       in case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
q' Map VName Mod
mods of
            Just (ModMod Scope
mod_scope) -> QualName VName -> Scope -> (QualName VName, Scope)
lookupSubstInScope (forall vn. [vn] -> vn -> QualName vn
QualName [VName]
qs VName
name) Scope
mod_scope
            Maybe Mod
_ -> (QualName VName
qn, Scope
scope)

instance Semigroup Scope where
  Scope Substitutions
ss1 Map VName Mod
mt1 <> :: Scope -> Scope -> Scope
<> Scope Substitutions
ss2 Map VName Mod
mt2 = Substitutions -> Map VName Mod -> Scope
Scope (Substitutions
ss1 forall a. Semigroup a => a -> a -> a
<> Substitutions
ss2) (Map VName Mod
mt1 forall a. Semigroup a => a -> a -> a
<> Map VName Mod
mt2)

instance Monoid Scope where
  mempty :: Scope
mempty = Substitutions -> Map VName Mod -> Scope
Scope forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

type TySet = S.Set VName

data Env = Env
  { Env -> Scope
envScope :: Scope,
    Env -> Bool
envGenerating :: Bool,
    Env -> Map ImportName Scope
envImports :: M.Map ImportName Scope,
    Env -> TySet
envAbs :: TySet
  }

newtype TransformM a = TransformM (RWS Env (DL.DList Dec) VNameSource a)
  deriving
    ( Functor TransformM
forall a. a -> TransformM a
forall a b. TransformM a -> TransformM b -> TransformM a
forall a b. TransformM a -> TransformM b -> TransformM b
forall a b. TransformM (a -> b) -> TransformM a -> TransformM b
forall a b c.
(a -> b -> c) -> TransformM a -> TransformM b -> TransformM 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
<* :: forall a b. TransformM a -> TransformM b -> TransformM a
$c<* :: forall a b. TransformM a -> TransformM b -> TransformM a
*> :: forall a b. TransformM a -> TransformM b -> TransformM b
$c*> :: forall a b. TransformM a -> TransformM b -> TransformM b
liftA2 :: forall a b c.
(a -> b -> c) -> TransformM a -> TransformM b -> TransformM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TransformM a -> TransformM b -> TransformM c
<*> :: forall a b. TransformM (a -> b) -> TransformM a -> TransformM b
$c<*> :: forall a b. TransformM (a -> b) -> TransformM a -> TransformM b
pure :: forall a. a -> TransformM a
$cpure :: forall a. a -> TransformM a
Applicative,
      forall a b. a -> TransformM b -> TransformM a
forall a b. (a -> b) -> TransformM a -> TransformM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TransformM b -> TransformM a
$c<$ :: forall a b. a -> TransformM b -> TransformM a
fmap :: forall a b. (a -> b) -> TransformM a -> TransformM b
$cfmap :: forall a b. (a -> b) -> TransformM a -> TransformM b
Functor,
      Applicative TransformM
forall a. a -> TransformM a
forall a b. TransformM a -> TransformM b -> TransformM b
forall a b. TransformM a -> (a -> TransformM b) -> TransformM 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 :: forall a. a -> TransformM a
$creturn :: forall a. a -> TransformM a
>> :: forall a b. TransformM a -> TransformM b -> TransformM b
$c>> :: forall a b. TransformM a -> TransformM b -> TransformM b
>>= :: forall a b. TransformM a -> (a -> TransformM b) -> TransformM b
$c>>= :: forall a b. TransformM a -> (a -> TransformM b) -> TransformM b
Monad,
      Monad TransformM
TransformM VNameSource
VNameSource -> TransformM ()
forall (m :: * -> *).
Monad m
-> m VNameSource -> (VNameSource -> m ()) -> MonadFreshNames m
putNameSource :: VNameSource -> TransformM ()
$cputNameSource :: VNameSource -> TransformM ()
getNameSource :: TransformM VNameSource
$cgetNameSource :: TransformM VNameSource
MonadFreshNames,
      MonadReader Env,
      MonadWriter (DL.DList Dec)
    )

emit :: Dec -> TransformM ()
emit :: Dec -> TransformM ()
emit = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> DList a
DL.singleton

askScope :: TransformM Scope
askScope :: TransformM Scope
askScope = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Scope
envScope

localScope :: (Scope -> Scope) -> TransformM a -> TransformM a
localScope :: forall a. (Scope -> Scope) -> TransformM a -> TransformM a
localScope Scope -> Scope
f = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env {envScope :: Scope
envScope = Scope -> Scope
f forall a b. (a -> b) -> a -> b
$ Env -> Scope
envScope Env
env}

extendScope :: Scope -> TransformM a -> TransformM a
extendScope :: forall a. Scope -> TransformM a -> TransformM a
extendScope (Scope Substitutions
substs Map VName Mod
mods) = forall a. (Scope -> Scope) -> TransformM a -> TransformM a
localScope forall a b. (a -> b) -> a -> b
$ \Scope
scope ->
  Scope
scope
    { scopeSubsts :: Substitutions
scopeSubsts = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall {k}. Ord k => Map k k -> k -> k
forward (Scope -> Substitutions
scopeSubsts Scope
scope)) Substitutions
substs forall a. Semigroup a => a -> a -> a
<> Scope -> Substitutions
scopeSubsts Scope
scope,
      scopeMods :: Map VName Mod
scopeMods = Map VName Mod
mods forall a. Semigroup a => a -> a -> a
<> Scope -> Map VName Mod
scopeMods Scope
scope
    }
  where
    forward :: Map k k -> k -> k
forward Map k k
old_substs k
v = forall a. a -> Maybe a -> a
fromMaybe k
v forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
v Map k k
old_substs

substituting :: Substitutions -> TransformM a -> TransformM a
substituting :: forall a. Substitutions -> TransformM a -> TransformM a
substituting Substitutions
substs = forall a. Scope -> TransformM a -> TransformM a
extendScope forall a. Monoid a => a
mempty {scopeSubsts :: Substitutions
scopeSubsts = Substitutions
substs}

boundName :: VName -> TransformM VName
boundName :: VName -> TransformM VName
boundName VName
v = do
  Bool
g <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
envGenerating
  if Bool
g then forall (m :: * -> *). MonadFreshNames m => VName -> m VName
newName VName
v else forall (f :: * -> *) a. Applicative f => a -> f a
pure VName
v

bindingNames :: [VName] -> TransformM Scope -> TransformM Scope
bindingNames :: [VName] -> TransformM Scope -> TransformM Scope
bindingNames [VName]
names TransformM Scope
m = do
  [VName]
names' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VName -> TransformM VName
boundName [VName]
names
  let substs :: Substitutions
substs = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
names [VName]
names')
  forall a. Substitutions -> TransformM a -> TransformM a
substituting Substitutions
substs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformM Scope
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Substitutions -> Map VName Mod -> Scope
Scope Substitutions
substs forall a. Monoid a => a
mempty)

generating :: TransformM a -> TransformM a
generating :: forall a. TransformM a -> TransformM a
generating = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env {envGenerating :: Bool
envGenerating = Bool
True}

bindingImport :: ImportName -> Scope -> TransformM a -> TransformM a
bindingImport :: forall a. ImportName -> Scope -> TransformM a -> TransformM a
bindingImport ImportName
name Scope
scope = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \Env
env ->
  Env
env {envImports :: Map ImportName Scope
envImports = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ImportName
name Scope
scope forall a b. (a -> b) -> a -> b
$ Env -> Map ImportName Scope
envImports Env
env}

bindingAbs :: TySet -> TransformM a -> TransformM a
bindingAbs :: forall a. TySet -> TransformM a -> TransformM a
bindingAbs TySet
abs = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \Env
env ->
  Env
env {envAbs :: TySet
envAbs = TySet
abs forall a. Semigroup a => a -> a -> a
<> Env -> TySet
envAbs Env
env}

lookupImport :: ImportName -> TransformM Scope
lookupImport :: ImportName -> TransformM Scope
lookupImport ImportName
name = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
bad forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ImportName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map ImportName Scope
envImports)
  where
    bad :: a
bad = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Defunctorise: unknown import: " forall a. [a] -> [a] -> [a]
++ ImportName -> [Char]
includeToString ImportName
name

lookupMod' :: QualName VName -> Scope -> Either String Mod
lookupMod' :: QualName VName -> Scope -> Either [Char] Mod
lookupMod' QualName VName
mname Scope
scope =
  let (QualName VName
mname', Scope
scope') = QualName VName -> Scope -> (QualName VName, Scope)
lookupSubstInScope QualName VName
mname Scope
scope
   in forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {a}. Pretty a => a -> [Char]
bad QualName VName
mname') (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod -> Mod
extend) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall vn. QualName vn -> vn
qualLeaf QualName VName
mname') forall a b. (a -> b) -> a -> b
$ Scope -> Map VName Mod
scopeMods Scope
scope'
  where
    bad :: a -> [Char]
bad a
mname' = [Char]
"Unknown module: " forall a. [a] -> [a] -> [a]
++ forall {a}. Pretty a => a -> [Char]
prettyString QualName VName
mname forall a. [a] -> [a] -> [a]
++ [Char]
" (" forall a. [a] -> [a] -> [a]
++ forall {a}. Pretty a => a -> [Char]
prettyString a
mname' forall a. [a] -> [a] -> [a]
++ [Char]
")"
    extend :: Mod -> Mod
extend (ModMod (Scope Substitutions
inner_scope Map VName Mod
inner_mods)) =
      -- XXX: perhaps hacky fix for #1653.  We need to impose the
      -- substitutions of abstract types from outside, because the
      -- inner module may have some incorrect substitutions in some
      -- cases.  Our treatment of abstract types is completely whack
      -- and should be fixed.
      Scope -> Mod
ModMod forall a b. (a -> b) -> a -> b
$ Substitutions -> Map VName Mod -> Scope
Scope (Scope -> Substitutions
scopeSubsts Scope
scope forall a. Semigroup a => a -> a -> a
<> Substitutions
inner_scope) Map VName Mod
inner_mods
    extend Mod
m = Mod
m

lookupMod :: QualName VName -> TransformM Mod
lookupMod :: QualName VName -> TransformM Mod
lookupMod QualName VName
mname = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualName VName -> Scope -> Either [Char] Mod
lookupMod' QualName VName
mname forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TransformM Scope
askScope

runTransformM :: VNameSource -> TransformM a -> (a, VNameSource, DL.DList Dec)
runTransformM :: forall a.
VNameSource -> TransformM a -> (a, VNameSource, DList Dec)
runTransformM VNameSource
src (TransformM RWS Env (DList Dec) VNameSource a
m) = forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS RWS Env (DList Dec) VNameSource a
m Env
env VNameSource
src
  where
    env :: Env
env = Scope -> Bool -> Map ImportName Scope -> TySet -> Env
Env forall a. Monoid a => a
mempty Bool
False forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

maybeAscript ::
  SrcLoc ->
  Maybe (SigExp, Info (M.Map VName VName)) ->
  ModExp ->
  ModExp
maybeAscript :: SrcLoc -> Maybe (SigExp, Info Substitutions) -> ModExp -> ModExp
maybeAscript SrcLoc
loc (Just (SigExp
mtye, Info Substitutions
substs)) ModExp
me = forall (f :: * -> *) vn.
ModExpBase f vn
-> SigExpBase f vn -> f Substitutions -> SrcLoc -> ModExpBase f vn
ModAscript ModExp
me SigExp
mtye Info Substitutions
substs SrcLoc
loc
maybeAscript SrcLoc
_ Maybe (SigExp, Info Substitutions)
Nothing ModExp
me = ModExp
me

substituteInMod :: Substitutions -> Mod -> Mod
substituteInMod :: Substitutions -> Mod -> Mod
substituteInMod Substitutions
substs (ModMod (Scope Substitutions
mod_substs Map VName Mod
mod_mods)) =
  -- Forward all substitutions.
  Scope -> Mod
ModMod forall a b. (a -> b) -> a -> b
$ Substitutions -> Map VName Mod -> Scope
Scope Substitutions
substs' forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Substitutions -> Mod -> Mod
substituteInMod Substitutions
substs) Map VName Mod
mod_mods
  where
    forward :: VName -> VName
forward VName
v = VName -> Substitutions -> VName
lookupSubst VName
v forall a b. (a -> b) -> a -> b
$ Substitutions
mod_substs forall a. Semigroup a => a -> a -> a
<> Substitutions
substs
    substs' :: Substitutions
substs' = forall a b k. (a -> b) -> Map k a -> Map k b
M.map VName -> VName
forward Substitutions
substs
substituteInMod Substitutions
substs (ModFun TySet
abs (Scope Substitutions
mod_substs Map VName Mod
mod_mods) ModParam
mparam ModExp
mbody) =
  TySet -> Scope -> ModParam -> ModExp -> Mod
ModFun TySet
abs (Substitutions -> Map VName Mod -> Scope
Scope (Substitutions
substs' forall a. Semigroup a => a -> a -> a
<> Substitutions
mod_substs) Map VName Mod
mod_mods) ModParam
mparam ModExp
mbody
  where
    forward :: VName -> VName
forward VName
v = VName -> Substitutions -> VName
lookupSubst VName
v Substitutions
mod_substs
    substs' :: Substitutions
substs' = forall a b k. (a -> b) -> Map k a -> Map k b
M.map VName -> VName
forward Substitutions
substs

extendAbsTypes :: Substitutions -> TransformM a -> TransformM a
extendAbsTypes :: forall a. Substitutions -> TransformM a -> TransformM a
extendAbsTypes Substitutions
ascript_substs TransformM a
m = do
  TySet
abs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TySet
envAbs
  -- Some abstract types may have a different name on the inside, and
  -- we need to make them visible, because substitutions involving
  -- abstract types must be lifted out in transformModBind.
  let subst_abs :: TySet
subst_abs =
        forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`S.member` TySet
abs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
          forall k a. Map k a -> [(k, a)]
M.toList Substitutions
ascript_substs
  forall a. TySet -> TransformM a -> TransformM a
bindingAbs TySet
subst_abs TransformM a
m

evalModExp :: ModExp -> TransformM Mod
evalModExp :: ModExp -> TransformM Mod
evalModExp (ModVar QualName VName
qn SrcLoc
_) = QualName VName -> TransformM Mod
lookupMod QualName VName
qn
evalModExp (ModParens ModExp
e SrcLoc
_) = ModExp -> TransformM Mod
evalModExp ModExp
e
evalModExp (ModDecs [Dec]
decs SrcLoc
_) = Scope -> Mod
ModMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec] -> TransformM Scope
transformDecs [Dec]
decs
evalModExp (ModImport [Char]
_ (Info ImportName
fpath) SrcLoc
_) = Scope -> Mod
ModMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportName -> TransformM Scope
lookupImport ImportName
fpath
evalModExp (ModAscript ModExp
me SigExp
_ (Info Substitutions
ascript_substs) SrcLoc
_) =
  forall a. Substitutions -> TransformM a -> TransformM a
extendAbsTypes Substitutions
ascript_substs forall a b. (a -> b) -> a -> b
$
    Substitutions -> Mod -> Mod
substituteInMod Substitutions
ascript_substs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModExp -> TransformM Mod
evalModExp ModExp
me
evalModExp (ModApply ModExp
f ModExp
arg (Info Substitutions
p_substs) (Info Substitutions
b_substs) SrcLoc
loc) = do
  Mod
f_mod <- ModExp -> TransformM Mod
evalModExp ModExp
f
  Mod
arg_mod <- ModExp -> TransformM Mod
evalModExp ModExp
arg
  case Mod
f_mod of
    ModMod Scope
_ ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot apply non-parametric module at " forall a. [a] -> [a] -> [a]
++ forall a. Located a => a -> [Char]
locStr SrcLoc
loc
    ModFun TySet
f_abs Scope
f_closure ModParam
f_p ModExp
f_body ->
      forall a. TySet -> TransformM a -> TransformM a
bindingAbs (TySet
f_abs forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
S.fromList (forall a. Info a -> a
unInfo (forall (f :: * -> *) vn. ModParamBase f vn -> f [VName]
modParamAbs ModParam
f_p)))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Substitutions -> TransformM a -> TransformM a
extendAbsTypes Substitutions
b_substs
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Scope -> Scope) -> TransformM a -> TransformM a
localScope (forall a b. a -> b -> a
const Scope
f_closure) -- Start afresh.
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TransformM a -> TransformM a
generating
        forall a b. (a -> b) -> a -> b
$ do
          TySet
abs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TySet
envAbs
          let keep :: VName -> p -> Bool
keep VName
k p
_ = VName
k forall k a. Ord k => k -> Map k a -> Bool
`M.member` Substitutions
p_substs Bool -> Bool -> Bool
|| VName
k forall a. Ord a => a -> Set a -> Bool
`S.member` TySet
abs
              abs_substs :: Substitutions
abs_substs =
                forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey forall {p}. VName -> p -> Bool
keep forall a b. (a -> b) -> a -> b
$
                  forall a b k. (a -> b) -> Map k a -> Map k b
M.map (VName -> Substitutions -> VName
`lookupSubst` Scope -> Substitutions
scopeSubsts (Mod -> Scope
modScope Mod
arg_mod)) Substitutions
p_substs
                    forall a. Semigroup a => a -> a -> a
<> Scope -> Substitutions
scopeSubsts Scope
f_closure
                    forall a. Semigroup a => a -> a -> a
<> Scope -> Substitutions
scopeSubsts (Mod -> Scope
modScope Mod
arg_mod)
          forall a. Scope -> TransformM a -> TransformM a
extendScope
            ( Substitutions -> Map VName Mod -> Scope
Scope
                Substitutions
abs_substs
                ( forall k a. k -> a -> Map k a
M.singleton (forall (f :: * -> *) vn. ModParamBase f vn -> vn
modParamName ModParam
f_p) forall a b. (a -> b) -> a -> b
$
                    Substitutions -> Mod -> Mod
substituteInMod Substitutions
p_substs Mod
arg_mod
                )
            )
            forall a b. (a -> b) -> a -> b
$ do
              Substitutions
substs <- Scope -> Substitutions
scopeSubsts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformM Scope
askScope
              Mod
x <- ModExp -> TransformM Mod
evalModExp ModExp
f_body
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                TySet -> Substitutions -> Mod -> Mod
addSubsts TySet
abs Substitutions
abs_substs forall a b. (a -> b) -> a -> b
$
                  -- The next one is dubious, but is necessary to
                  -- propagate substitutions from the argument (see
                  -- modules/functor24.fut).
                  Substitutions -> Mod -> Mod
addSubstsModMod (Scope -> Substitutions
scopeSubsts forall a b. (a -> b) -> a -> b
$ Mod -> Scope
modScope Mod
arg_mod) forall a b. (a -> b) -> a -> b
$
                    Substitutions -> Mod -> Mod
substituteInMod (Substitutions
b_substs forall a. Semigroup a => a -> a -> a
<> Substitutions
substs) Mod
x
  where
    addSubsts :: TySet -> Substitutions -> Mod -> Mod
addSubsts TySet
abs Substitutions
substs (ModFun TySet
mabs (Scope Substitutions
msubsts Map VName Mod
mods) ModParam
mp ModExp
me) =
      TySet -> Scope -> ModParam -> ModExp -> Mod
ModFun (TySet
abs forall a. Semigroup a => a -> a -> a
<> TySet
mabs) (Substitutions -> Map VName Mod -> Scope
Scope (Substitutions
substs forall a. Semigroup a => a -> a -> a
<> Substitutions
msubsts) Map VName Mod
mods) ModParam
mp ModExp
me
    addSubsts TySet
_ Substitutions
substs (ModMod (Scope Substitutions
msubsts Map VName Mod
mods)) =
      Scope -> Mod
ModMod forall a b. (a -> b) -> a -> b
$ Substitutions -> Map VName Mod -> Scope
Scope (Substitutions
substs forall a. Semigroup a => a -> a -> a
<> Substitutions
msubsts) Map VName Mod
mods
    addSubstsModMod :: Substitutions -> Mod -> Mod
addSubstsModMod Substitutions
substs (ModMod (Scope Substitutions
msubsts Map VName Mod
mods)) =
      Scope -> Mod
ModMod forall a b. (a -> b) -> a -> b
$ Substitutions -> Map VName Mod -> Scope
Scope (Substitutions
substs forall a. Semigroup a => a -> a -> a
<> Substitutions
msubsts) Map VName Mod
mods
    addSubstsModMod Substitutions
_ Mod
m = Mod
m
evalModExp (ModLambda ModParam
p Maybe (SigExp, Info Substitutions)
ascript ModExp
e SrcLoc
loc) = do
  Scope
scope <- TransformM Scope
askScope
  TySet
abs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TySet
envAbs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TySet -> Scope -> ModParam -> ModExp -> Mod
ModFun TySet
abs Scope
scope ModParam
p forall a b. (a -> b) -> a -> b
$ SrcLoc -> Maybe (SigExp, Info Substitutions) -> ModExp -> ModExp
maybeAscript SrcLoc
loc Maybe (SigExp, Info Substitutions)
ascript ModExp
e

transformName :: VName -> TransformM VName
transformName :: VName -> TransformM VName
transformName VName
v = VName -> Substitutions -> VName
lookupSubst VName
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> Substitutions
scopeSubsts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformM Scope
askScope

-- | A general-purpose substitution of names.
transformNames :: ASTMappable x => x -> TransformM x
transformNames :: forall x. ASTMappable x => x -> TransformM x
transformNames x
x = do
  Scope
scope <- TransformM Scope
askScope
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (forall {m :: * -> *}. Monad m => Scope -> ASTMapper m
substituter Scope
scope) x
x
  where
    substituter :: Scope -> ASTMapper m
substituter Scope
scope =
      ASTMapper
        { mapOnExp :: Exp -> m Exp
mapOnExp = Scope -> Exp -> m Exp
onExp Scope
scope,
          mapOnName :: VName -> m VName
mapOnName = \VName
v ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall vn. QualName vn -> vn
qualLeaf forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ QualName VName -> Scope -> (QualName VName, Scope)
lookupSubstInScope (forall v. v -> QualName v
qualName VName
v) Scope
scope,
          mapOnStructType :: StructType -> m StructType
mapOnStructType = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter Scope
scope),
          mapOnPatType :: PatType -> m PatType
mapOnPatType = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter Scope
scope),
          mapOnStructRetType :: StructRetType -> m StructRetType
mapOnStructRetType = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter Scope
scope),
          mapOnPatRetType :: PatRetType -> m PatRetType
mapOnPatRetType = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter Scope
scope)
        }
    onExp :: Scope -> Exp -> m Exp
onExp Scope
scope Exp
e =
      -- One expression is tricky, because it interacts with scoping rules.
      case Exp
e of
        QualParens (QualName VName
mn, SrcLoc
_) Exp
e' SrcLoc
_ ->
          case QualName VName -> Scope -> Either [Char] Mod
lookupMod' QualName VName
mn Scope
scope of
            Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error [Char]
err
            Right Mod
mod ->
              forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter forall a b. (a -> b) -> a -> b
$ Mod -> Scope
modScope Mod
mod forall a. Semigroup a => a -> a -> a
<> Scope
scope) Exp
e'
        Exp
_ -> forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap (Scope -> ASTMapper m
substituter Scope
scope) Exp
e

transformTypeExp :: TypeExp Info VName -> TransformM (TypeExp Info VName)
transformTypeExp :: TypeExp Info VName -> TransformM (TypeExp Info VName)
transformTypeExp = forall x. ASTMappable x => x -> TransformM x
transformNames

transformStructType :: StructType -> TransformM StructType
transformStructType :: StructType -> TransformM StructType
transformStructType = forall x. ASTMappable x => x -> TransformM x
transformNames

transformExp :: Exp -> TransformM Exp
transformExp :: Exp -> TransformM Exp
transformExp = forall x. ASTMappable x => x -> TransformM x
transformNames

transformEntry :: EntryPoint -> TransformM EntryPoint
transformEntry :: EntryPoint -> TransformM EntryPoint
transformEntry (EntryPoint [EntryParam]
params EntryType
ret) =
  [EntryParam] -> EntryType -> EntryPoint
EntryPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EntryParam -> TransformM EntryParam
onEntryParam [EntryParam]
params forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EntryType -> TransformM EntryType
onEntryType EntryType
ret
  where
    onEntryParam :: EntryParam -> TransformM EntryParam
onEntryParam (EntryParam Name
v EntryType
t) =
      Name -> EntryType -> EntryParam
EntryParam Name
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntryType -> TransformM EntryType
onEntryType EntryType
t
    onEntryType :: EntryType -> TransformM EntryType
onEntryType (EntryType StructType
t Maybe (TypeExp Info VName)
te) =
      StructType -> Maybe (TypeExp Info VName) -> EntryType
EntryType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StructType -> TransformM StructType
transformStructType StructType
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypeExp Info VName)
te

transformValBind :: ValBind -> TransformM ()
transformValBind :: ValBind -> TransformM ()
transformValBind (ValBind Maybe (Info EntryPoint)
entry VName
name Maybe (TypeExp Info VName)
tdecl (Info (RetType [VName]
dims StructType
t)) [TypeParamBase VName]
tparams [PatBase Info VName]
params Exp
e Maybe DocComment
doc [AttrInfo VName]
attrs SrcLoc
loc) = do
  Maybe (Info EntryPoint)
entry' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse EntryPoint -> TransformM EntryPoint
transformEntry) Maybe (Info EntryPoint)
entry
  VName
name' <- VName -> TransformM VName
transformName VName
name
  Maybe (TypeExp Info VName)
tdecl' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeExp Info VName -> TransformM (TypeExp Info VName)
transformTypeExp Maybe (TypeExp Info VName)
tdecl
  StructType
t' <- StructType -> TransformM StructType
transformStructType StructType
t
  Exp
e' <- Exp -> TransformM Exp
transformExp Exp
e
  [TypeParamBase VName]
tparams' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall x. ASTMappable x => x -> TransformM x
transformNames [TypeParamBase VName]
tparams
  [PatBase Info VName]
params' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall x. ASTMappable x => x -> TransformM x
transformNames [PatBase Info VName]
params
  Dec -> TransformM ()
emit forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn.
Maybe (f EntryPoint)
-> vn
-> Maybe (TypeExp f vn)
-> f StructRetType
-> [TypeParamBase vn]
-> [PatBase f vn]
-> ExpBase f vn
-> Maybe DocComment
-> [AttrInfo vn]
-> SrcLoc
-> ValBindBase f vn
ValBind Maybe (Info EntryPoint)
entry' VName
name' Maybe (TypeExp Info VName)
tdecl' (forall a. a -> Info a
Info (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims StructType
t')) [TypeParamBase VName]
tparams' [PatBase Info VName]
params' Exp
e' Maybe DocComment
doc [AttrInfo VName]
attrs SrcLoc
loc

transformTypeBind :: TypeBind -> TransformM ()
transformTypeBind :: TypeBind -> TransformM ()
transformTypeBind (TypeBind VName
name Liftedness
l [TypeParamBase VName]
tparams TypeExp Info VName
te (Info (RetType [VName]
dims StructType
t)) Maybe DocComment
doc SrcLoc
loc) = do
  VName
name' <- VName -> TransformM VName
transformName VName
name
  Dec -> TransformM ()
emit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) vn. TypeBindBase f vn -> DecBase f vn
TypeDec
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ( forall (f :: * -> *) vn.
vn
-> Liftedness
-> [TypeParamBase vn]
-> TypeExp f vn
-> f StructRetType
-> Maybe DocComment
-> SrcLoc
-> TypeBindBase f vn
TypeBind VName
name' Liftedness
l
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall x. ASTMappable x => x -> TransformM x
transformNames [TypeParamBase VName]
tparams
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExp Info VName -> TransformM (TypeExp Info VName)
transformTypeExp TypeExp Info VName
te
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Info a
Info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StructType -> TransformM StructType
transformStructType StructType
t)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DocComment
doc
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
        )

transformModBind :: ModBind -> TransformM Scope
transformModBind :: ModBind -> TransformM Scope
transformModBind ModBind
mb = do
  let addParam :: ModParamBase f vn -> ModExpBase f vn -> ModExpBase f vn
addParam ModParamBase f vn
p ModExpBase f vn
me = forall (f :: * -> *) vn.
ModParamBase f vn
-> Maybe (SigExpBase f vn, f Substitutions)
-> ModExpBase f vn
-> SrcLoc
-> ModExpBase f vn
ModLambda ModParamBase f vn
p forall a. Maybe a
Nothing ModExpBase f vn
me forall a b. (a -> b) -> a -> b
$ forall a. Located a => a -> SrcLoc
srclocOf ModExpBase f vn
me
  Mod
mod <-
    ModExp -> TransformM Mod
evalModExp
      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        forall {f :: * -> *} {vn}.
ModParamBase f vn -> ModExpBase f vn -> ModExpBase f vn
addParam
        (SrcLoc -> Maybe (SigExp, Info Substitutions) -> ModExp -> ModExp
maybeAscript (forall a. Located a => a -> SrcLoc
srclocOf ModBind
mb) (forall (f :: * -> *) vn.
ModBindBase f vn -> Maybe (SigExpBase f vn, f Substitutions)
modSignature ModBind
mb) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. ModBindBase f vn -> ModExpBase f vn
modExp ModBind
mb)
      forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. ModBindBase f vn -> [ModParamBase f vn]
modParams ModBind
mb
  VName
mname <- VName -> TransformM VName
transformName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. ModBindBase f vn -> vn
modName ModBind
mb
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Substitutions -> Map VName Mod -> Scope
Scope (Scope -> Substitutions
scopeSubsts forall a b. (a -> b) -> a -> b
$ Mod -> Scope
modScope Mod
mod) forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton VName
mname Mod
mod

transformDecs :: [Dec] -> TransformM Scope
transformDecs :: [Dec] -> TransformM Scope
transformDecs [Dec]
ds =
  case [Dec]
ds of
    [] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    LocalDec Dec
d SrcLoc
_ : [Dec]
ds' ->
      [Dec] -> TransformM Scope
transformDecs forall a b. (a -> b) -> a -> b
$ Dec
d forall a. a -> [a] -> [a]
: [Dec]
ds'
    ValDec ValBind
fdec : [Dec]
ds' ->
      [VName] -> TransformM Scope -> TransformM Scope
bindingNames [forall (f :: * -> *) vn. ValBindBase f vn -> vn
valBindName ValBind
fdec] forall a b. (a -> b) -> a -> b
$ do
        ValBind -> TransformM ()
transformValBind ValBind
fdec
        [Dec] -> TransformM Scope
transformDecs [Dec]
ds'
    TypeDec TypeBind
tb : [Dec]
ds' ->
      [VName] -> TransformM Scope -> TransformM Scope
bindingNames [forall (f :: * -> *) vn. TypeBindBase f vn -> vn
typeAlias TypeBind
tb] forall a b. (a -> b) -> a -> b
$ do
        TypeBind -> TransformM ()
transformTypeBind TypeBind
tb
        [Dec] -> TransformM Scope
transformDecs [Dec]
ds'
    SigDec {} : [Dec]
ds' ->
      [Dec] -> TransformM Scope
transformDecs [Dec]
ds'
    ModDec ModBind
mb : [Dec]
ds' ->
      [VName] -> TransformM Scope -> TransformM Scope
bindingNames [forall (f :: * -> *) vn. ModBindBase f vn -> vn
modName ModBind
mb] forall a b. (a -> b) -> a -> b
$ do
        Scope
mod_scope <- ModBind -> TransformM Scope
transformModBind ModBind
mb
        forall a. Scope -> TransformM a -> TransformM a
extendScope Scope
mod_scope forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec] -> TransformM Scope
transformDecs [Dec]
ds' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scope
mod_scope
    OpenDec ModExp
e SrcLoc
_ : [Dec]
ds' -> do
      Scope
scope <- Mod -> Scope
modScope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModExp -> TransformM Mod
evalModExp ModExp
e
      forall a. Scope -> TransformM a -> TransformM a
extendScope Scope
scope forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec] -> TransformM Scope
transformDecs [Dec]
ds' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scope
scope
    ImportDec [Char]
name Info ImportName
name' SrcLoc
loc : [Dec]
ds' ->
      let d :: DecBase Info vn
d = forall (f :: * -> *) vn. DecBase f vn -> SrcLoc -> DecBase f vn
LocalDec (forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec (forall (f :: * -> *) vn.
[Char] -> f ImportName -> SrcLoc -> ModExpBase f vn
ModImport [Char]
name Info ImportName
name' SrcLoc
loc) SrcLoc
loc) SrcLoc
loc
       in [Dec] -> TransformM Scope
transformDecs forall a b. (a -> b) -> a -> b
$ forall {vn}. DecBase Info vn
d forall a. a -> [a] -> [a]
: [Dec]
ds'

transformImports :: Imports -> TransformM ()
transformImports :: Imports -> TransformM ()
transformImports [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
transformImports ((ImportName
name, FileModule
imp) : Imports
imps) = do
  let abs :: TySet
abs = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall vn. QualName vn -> vn
qualLeaf forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ FileModule -> TySet
fileAbs FileModule
imp
  Scope
scope <-
    forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {f :: * -> *} {vn}. DecBase f vn -> DecBase f vn
maybeHideEntryPoint) forall a b. (a -> b) -> a -> b
$
      forall a. TySet -> TransformM a -> TransformM a
bindingAbs TySet
abs forall a b. (a -> b) -> a -> b
$
        [Dec] -> TransformM Scope
transformDecs forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) vn. ProgBase f vn -> [DecBase f vn]
progDecs forall a b. (a -> b) -> a -> b
$
            FileModule -> Prog
fileProg FileModule
imp
  forall a. TySet -> TransformM a -> TransformM a
bindingAbs TySet
abs forall a b. (a -> b) -> a -> b
$ forall a. ImportName -> Scope -> TransformM a -> TransformM a
bindingImport ImportName
name Scope
scope forall a b. (a -> b) -> a -> b
$ Imports -> TransformM ()
transformImports Imports
imps
  where
    -- Only the "main" file (last import) is allowed to have entry points.
    permit_entry_points :: Bool
permit_entry_points = forall (t :: * -> *) a. Foldable t => t a -> Bool
null Imports
imps

    maybeHideEntryPoint :: DecBase f vn -> DecBase f vn
maybeHideEntryPoint (ValDec ValBindBase f vn
vdec) =
      forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec
        ValBindBase f vn
vdec
          { valBindEntryPoint :: Maybe (f EntryPoint)
valBindEntryPoint =
              if Bool
permit_entry_points
                then forall (f :: * -> *) vn. ValBindBase f vn -> Maybe (f EntryPoint)
valBindEntryPoint ValBindBase f vn
vdec
                else forall a. Maybe a
Nothing
          }
    maybeHideEntryPoint DecBase f vn
d = DecBase f vn
d

-- | Perform defunctorisation.
transformProg :: MonadFreshNames m => Imports -> m [Dec]
transformProg :: forall (m :: * -> *). MonadFreshNames m => Imports -> m [Dec]
transformProg Imports
prog = forall (m :: * -> *) a.
MonadFreshNames m =>
(VNameSource -> (a, VNameSource)) -> m a
modifyNameSource forall a b. (a -> b) -> a -> b
$ \VNameSource
namesrc ->
  let ((), VNameSource
namesrc', DList Dec
prog') = forall a.
VNameSource -> TransformM a -> (a, VNameSource, DList Dec)
runTransformM VNameSource
namesrc forall a b. (a -> b) -> a -> b
$ Imports -> TransformM ()
transformImports Imports
prog
   in (forall a. DList a -> [a]
DL.toList DList Dec
prog', VNameSource
namesrc')