{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

-- | This module is kind of half-assed. I don't have any references and it fails
-- under various corner cases.
module Kempe.Monomorphize ( closedModule
                          , MonoM
                          , runMonoM
                          , flattenModule
                          , tryMono
                          , tryMonoConsAnn
                          , ConsAnn (..)
                          -- * Benchmark
                          , closure
                          , mkModuleMap
                          ) where

import           Control.Monad              ((<=<))
import           Control.Monad.Except       (MonadError, throwError)
import           Control.Monad.State.Strict (StateT, gets, runStateT)
import           Data.Bifunctor             (second)
import           Data.Function              (on)
import           Data.Functor               (($>))
import qualified Data.IntMap                as IM
import           Data.List                  (find, groupBy, partition)
import qualified Data.Map                   as M
import           Data.Maybe                 (fromMaybe, mapMaybe)
import qualified Data.Set                   as S
import qualified Data.Text                  as T
import           Data.Tuple.Extra           (fst3, snd3, thd3)
import           Kempe.AST
import           Kempe.Error
import           Kempe.Name
import           Kempe.Unique
import           Lens.Micro                 (Lens')
import           Lens.Micro.Mtl             (modifying)

-- | New function names, keyed by name + specialized type
--
-- also max state threaded through.
data RenameEnv = RenameEnv { RenameEnv -> Int
maxState :: Int
                           , RenameEnv -> Map (Unique, StackType ()) Unique
fnEnv    :: M.Map (Unique, StackType ()) Unique
                           , RenameEnv
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
consEnv  :: M.Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
                           }

type MonoM = StateT RenameEnv (Either (Error ()))

maxStateLens :: Lens' RenameEnv Int
maxStateLens :: (Int -> f Int) -> RenameEnv -> f RenameEnv
maxStateLens Int -> f Int
f RenameEnv
s = (Int -> RenameEnv) -> f Int -> f RenameEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
x -> RenameEnv
s { maxState :: Int
maxState = Int
x }) (Int -> f Int
f (RenameEnv -> Int
maxState RenameEnv
s))

consEnvLens :: Lens' RenameEnv (M.Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
consEnvLens :: (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
 -> f (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))))
-> RenameEnv -> f RenameEnv
consEnvLens Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> f (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
f RenameEnv
s = (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
 -> RenameEnv)
-> f (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
-> f RenameEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
x -> RenameEnv
s { consEnv :: Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
consEnv = Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
x }) (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> f (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
f (RenameEnv
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
consEnv RenameEnv
s))

fnEnvLens :: Lens' RenameEnv (M.Map (Unique, StackType ()) Unique)
fnEnvLens :: (Map (Unique, StackType ()) Unique
 -> f (Map (Unique, StackType ()) Unique))
-> RenameEnv -> f RenameEnv
fnEnvLens Map (Unique, StackType ()) Unique
-> f (Map (Unique, StackType ()) Unique)
f RenameEnv
s = (Map (Unique, StackType ()) Unique -> RenameEnv)
-> f (Map (Unique, StackType ()) Unique) -> f RenameEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map (Unique, StackType ()) Unique
x -> RenameEnv
s { fnEnv :: Map (Unique, StackType ()) Unique
fnEnv = Map (Unique, StackType ()) Unique
x }) (Map (Unique, StackType ()) Unique
-> f (Map (Unique, StackType ()) Unique)
f (RenameEnv -> Map (Unique, StackType ()) Unique
fnEnv RenameEnv
s))

runMonoM :: Int -> MonoM a -> Either (Error ()) (a, Int)
runMonoM :: Int -> MonoM a -> Either (Error ()) (a, Int)
runMonoM Int
maxI = ((a, RenameEnv) -> (a, Int))
-> Either (Error ()) (a, RenameEnv) -> Either (Error ()) (a, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RenameEnv -> Int) -> (a, RenameEnv) -> (a, Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RenameEnv -> Int
maxState) (Either (Error ()) (a, RenameEnv) -> Either (Error ()) (a, Int))
-> (MonoM a -> Either (Error ()) (a, RenameEnv))
-> MonoM a
-> Either (Error ()) (a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MonoM a -> RenameEnv -> Either (Error ()) (a, RenameEnv))
-> RenameEnv -> MonoM a -> Either (Error ()) (a, RenameEnv)
forall a b c. (a -> b -> c) -> b -> a -> c
flip MonoM a -> RenameEnv -> Either (Error ()) (a, RenameEnv)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Int
-> Map (Unique, StackType ()) Unique
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> RenameEnv
RenameEnv Int
maxI Map (Unique, StackType ()) Unique
forall a. Monoid a => a
mempty Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
forall a. Monoid a => a
mempty)

freshName :: T.Text -> a -> MonoM (Name a)
freshName :: Text -> a -> MonoM (Name a)
freshName Text
n a
ty = do
    Int
pSt <- (RenameEnv -> Int) -> StateT RenameEnv (Either (Error ())) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv -> Int
maxState
    Text -> Unique -> a -> Name a
forall a. Text -> Unique -> a -> Name a
Name Text
n (Int -> Unique
Unique (Int -> Unique) -> Int -> Unique
forall a b. (a -> b) -> a -> b
$ Int
pSt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
ty
        Name a -> StateT RenameEnv (Either (Error ())) () -> MonoM (Name a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ASetter RenameEnv RenameEnv Int Int
-> (Int -> Int) -> StateT RenameEnv (Either (Error ())) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter RenameEnv RenameEnv Int Int
Lens' RenameEnv Int
maxStateLens (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

tryMono :: MonadError (Error ()) m => StackType () -> m MonoStackType
tryMono :: StackType () -> m MonoStackType
tryMono (StackType Set (Name ())
_ [KempeTy ()]
is [KempeTy ()]
os) | Set (Name ()) -> Bool
forall a. Set a -> Bool
S.null ([KempeTy ()] -> Set (Name ())
forall a. [KempeTy a] -> Set (Name a)
freeVars ([KempeTy ()]
is [KempeTy ()] -> [KempeTy ()] -> [KempeTy ()]
forall a. [a] -> [a] -> [a]
++ [KempeTy ()]
os)) = MonoStackType -> m MonoStackType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([KempeTy ()]
is, [KempeTy ()]
os)
                            | Bool
otherwise = Error () -> m MonoStackType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error () -> m MonoStackType) -> Error () -> m MonoStackType
forall a b. (a -> b) -> a -> b
$ () -> Error ()
forall a. a -> Error a
MonoFailed ()

-- TODO: possible to get rid of this?
tryMonoConsAnn :: MonadError (Error ()) m => ConsAnn (StackType ()) -> m (ConsAnn MonoStackType)
tryMonoConsAnn :: ConsAnn (StackType ()) -> m (ConsAnn MonoStackType)
tryMonoConsAnn = (StackType () -> m MonoStackType)
-> ConsAnn (StackType ()) -> m (ConsAnn MonoStackType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StackType () -> m MonoStackType
forall (m :: * -> *).
MonadError (Error ()) m =>
StackType () -> m MonoStackType
tryMono

-- | A 'ModuleMap' is a map which retrives the 'KempeDecl' associated with
-- a given 'Name'
type ModuleMap a c b = IM.IntMap (KempeDecl a c b)

mkModuleMap :: Module a c b -> ModuleMap a c b
mkModuleMap :: Module a c b -> ModuleMap a c b
mkModuleMap = [(Int, KempeDecl a c b)] -> ModuleMap a c b
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, KempeDecl a c b)] -> ModuleMap a c b)
-> (Module a c b -> [(Int, KempeDecl a c b)])
-> Module a c b
-> ModuleMap a c b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KempeDecl a c b -> [(Int, KempeDecl a c b)])
-> Module a c b -> [(Int, KempeDecl a c b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap KempeDecl a c b -> [(Int, KempeDecl a c b)]
forall a c b. KempeDecl a c b -> [(Int, KempeDecl a c b)]
toInt where
    toInt :: KempeDecl a c b -> [(Int, KempeDecl a c b)]
toInt d :: KempeDecl a c b
d@(FunDecl b
_ (Name Text
_ (Unique Int
i) b
_) [KempeTy a]
_ [KempeTy a]
_ [Atom c b]
_)   = [(Int
i, KempeDecl a c b
d)]
    toInt d :: KempeDecl a c b
d@(ExtFnDecl b
_ (Name Text
_ (Unique Int
i) b
_) [KempeTy a]
_ [KempeTy a]
_ ByteString
_) = [(Int
i, KempeDecl a c b
d)]
    toInt d :: KempeDecl a c b
d@(TyDecl a
_ TyName a
_ [TyName a]
_ [(Name b, [KempeTy a])]
ds)                         =
        let us :: [Int]
us = Unique -> Int
unUnique (Unique -> Int)
-> ((Name b, [KempeTy a]) -> Unique)
-> (Name b, [KempeTy a])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name b -> Unique
forall a. Name a -> Unique
unique (Name b -> Unique)
-> ((Name b, [KempeTy a]) -> Name b)
-> (Name b, [KempeTy a])
-> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name b, [KempeTy a]) -> Name b
forall a b. (a, b) -> a
fst ((Name b, [KempeTy a]) -> Int) -> [(Name b, [KempeTy a])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name b, [KempeTy a])]
ds
            in (, KempeDecl a c b
d) (Int -> (Int, KempeDecl a c b))
-> [Int] -> [(Int, KempeDecl a c b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
us
    toInt KempeDecl a c b
_                                           = []

squishTypeName :: BuiltinTy -> T.Text
squishTypeName :: BuiltinTy -> Text
squishTypeName BuiltinTy
TyInt  = Text
"int"
squishTypeName BuiltinTy
TyBool = Text
"bool"
squishTypeName BuiltinTy
TyWord = Text
"word"
squishTypeName BuiltinTy
TyInt8 = Text
"int8"

squishType :: KempeTy a -> T.Text
squishType :: KempeTy a -> Text
squishType (TyBuiltin a
_ BuiltinTy
b)          = BuiltinTy -> Text
squishTypeName BuiltinTy
b
squishType (TyNamed a
_ (Name Text
t Unique
_ a
_)) = Text -> Text
T.toLower Text
t
squishType TyVar{}                  = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"not meant to be monomorphized!"
squishType (TyApp a
_ KempeTy a
ty KempeTy a
ty')         = KempeTy a -> Text
forall a. KempeTy a -> Text
squishType KempeTy a
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KempeTy a -> Text
forall a. KempeTy a -> Text
squishType KempeTy a
ty'

squishMonoStackType :: MonoStackType -> T.Text
squishMonoStackType :: MonoStackType -> Text
squishMonoStackType ([KempeTy ()]
is, [KempeTy ()]
os) = (KempeTy () -> Text) -> [KempeTy ()] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap KempeTy () -> Text
forall a. KempeTy a -> Text
squishType [KempeTy ()]
is Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"TT" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (KempeTy () -> Text) -> [KempeTy ()] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap KempeTy () -> Text
forall a. KempeTy a -> Text
squishType [KempeTy ()]
os

renamePattern :: Pattern (StackType ()) (StackType ()) -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
renamePattern :: Pattern (StackType ()) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
renamePattern (PatternInt StackType ()
ty Integer
i)    = Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern (ConsAnn (StackType ())) (StackType ())
 -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ())))
-> Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Integer -> Pattern (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Integer -> Pattern c b
PatternInt StackType ()
ty Integer
i
renamePattern (PatternWildcard StackType ()
ty) = Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern (ConsAnn (StackType ())) (StackType ())
 -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ())))
-> Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType () -> Pattern (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Pattern c b
PatternWildcard StackType ()
ty
renamePattern (PatternBool StackType ()
ty Bool
b)   = Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern (ConsAnn (StackType ())) (StackType ())
 -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ())))
-> Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Bool -> Pattern (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Bool -> Pattern c b
PatternBool StackType ()
ty Bool
b
renamePattern (PatternCons StackType ()
ty (Name Text
t Unique
u StackType ()
_)) = do
    Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
cSt <- (RenameEnv
 -> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
consEnv
    let (Unique
u', ConsAnn (StackType ())
ann) = (Unique, ConsAnn (StackType ()))
-> (Unique, StackType ())
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> (Unique, ConsAnn (StackType ()))
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Char] -> (Unique, ConsAnn (StackType ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error? unfound constructor") (Unique
u, StackType () -> StackType ()
flipStackType StackType ()
ty) Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
cSt
        ann' :: ConsAnn (StackType ())
ann' = StackType () -> StackType ()
flipStackType (StackType () -> StackType ())
-> ConsAnn (StackType ()) -> ConsAnn (StackType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsAnn (StackType ())
ann
    Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern (ConsAnn (StackType ())) (StackType ())
 -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ())))
-> Pattern (ConsAnn (StackType ())) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ ConsAnn (StackType ())
-> TyName (ConsAnn (StackType ()))
-> Pattern (ConsAnn (StackType ())) (StackType ())
forall c b. c -> TyName c -> Pattern c b
PatternCons ConsAnn (StackType ())
ann' (Text
-> Unique
-> ConsAnn (StackType ())
-> TyName (ConsAnn (StackType ()))
forall a. Text -> Unique -> a -> Name a
Name Text
t Unique
u' ConsAnn (StackType ())
ann')

renameCase :: (Pattern (StackType ()) (StackType ()), [Atom (StackType ()) (StackType ())]) -> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()), [Atom (ConsAnn (StackType ())) (StackType ())])
renameCase :: (Pattern (StackType ()) (StackType ()),
 [Atom (StackType ()) (StackType ())])
-> MonoM
     (Pattern (ConsAnn (StackType ())) (StackType ()),
      [Atom (ConsAnn (StackType ())) (StackType ())])
renameCase (Pattern (StackType ()) (StackType ())
p, [Atom (StackType ()) (StackType ())]
as) = (,) (Pattern (ConsAnn (StackType ())) (StackType ())
 -> [Atom (ConsAnn (StackType ())) (StackType ())]
 -> (Pattern (ConsAnn (StackType ())) (StackType ()),
     [Atom (ConsAnn (StackType ())) (StackType ())]))
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     ([Atom (ConsAnn (StackType ())) (StackType ())]
      -> (Pattern (ConsAnn (StackType ())) (StackType ()),
          [Atom (ConsAnn (StackType ())) (StackType ())]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern (StackType ()) (StackType ())
-> MonoM (Pattern (ConsAnn (StackType ())) (StackType ()))
renamePattern Pattern (StackType ()) (StackType ())
p StateT
  RenameEnv
  (Either (Error ()))
  ([Atom (ConsAnn (StackType ())) (StackType ())]
   -> (Pattern (ConsAnn (StackType ())) (StackType ()),
       [Atom (ConsAnn (StackType ())) (StackType ())]))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
-> MonoM
     (Pattern (ConsAnn (StackType ())) (StackType ()),
      [Atom (ConsAnn (StackType ())) (StackType ())])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as

renameAtom :: Atom (StackType ()) (StackType ()) -> MonoM (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom :: Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom (AtBuiltin StackType ()
ty BuiltinFn
b)         = Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> BuiltinFn -> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> BuiltinFn -> Atom c b
AtBuiltin StackType ()
ty BuiltinFn
b
renameAtom (If StackType ()
ty [Atom (StackType ()) (StackType ())]
as [Atom (StackType ()) (StackType ())]
as')           = StackType ()
-> [Atom (ConsAnn (StackType ())) (StackType ())]
-> [Atom (ConsAnn (StackType ())) (StackType ())]
-> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> [Atom c b] -> [Atom c b] -> Atom c b
If StackType ()
ty ([Atom (ConsAnn (StackType ())) (StackType ())]
 -> [Atom (ConsAnn (StackType ())) (StackType ())]
 -> Atom (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     ([Atom (ConsAnn (StackType ())) (StackType ())]
      -> Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as StateT
  RenameEnv
  (Either (Error ()))
  ([Atom (ConsAnn (StackType ())) (StackType ())]
   -> Atom (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as'
renameAtom (IntLit StackType ()
ty Integer
i)            = Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Integer -> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Integer -> Atom c b
IntLit StackType ()
ty Integer
i
renameAtom (Int8Lit StackType ()
ty Int8
i)           = Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Int8 -> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Int8 -> Atom c b
Int8Lit StackType ()
ty Int8
i
renameAtom (WordLit StackType ()
ty Natural
w)           = Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Natural -> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Natural -> Atom c b
WordLit StackType ()
ty Natural
w
renameAtom (BoolLit StackType ()
ty Bool
b)           = Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Bool -> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Bool -> Atom c b
BoolLit StackType ()
ty Bool
b
renameAtom (Dip StackType ()
ty [Atom (StackType ()) (StackType ())]
as)              = StackType ()
-> [Atom (ConsAnn (StackType ())) (StackType ())]
-> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> [Atom c b] -> Atom c b
Dip StackType ()
ty ([Atom (ConsAnn (StackType ())) (StackType ())]
 -> Atom (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as
renameAtom (AtName StackType ()
ty (Name Text
t Unique
u StackType ()
l)) = do
    Map (Unique, StackType ()) Unique
mSt <- (RenameEnv -> Map (Unique, StackType ()) Unique)
-> StateT
     RenameEnv (Either (Error ())) (Map (Unique, StackType ()) Unique)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv -> Map (Unique, StackType ()) Unique
fnEnv
    let u' :: Unique
u' = Unique
-> (Unique, StackType ())
-> Map (Unique, StackType ()) Unique
-> Unique
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Unique
u (Unique
u, StackType ()
ty) Map (Unique, StackType ()) Unique
mSt
    Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Name (StackType ())
-> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> Name b -> Atom c b
AtName StackType ()
ty (Text -> Unique -> StackType () -> Name (StackType ())
forall a. Text -> Unique -> a -> Name a
Name Text
t Unique
u' StackType ()
l)
renameAtom (Case StackType ()
ty NonEmpty
  (Pattern (StackType ()) (StackType ()),
   [Atom (StackType ()) (StackType ())])
ls)             = StackType ()
-> NonEmpty
     (Pattern (ConsAnn (StackType ())) (StackType ()),
      [Atom (ConsAnn (StackType ())) (StackType ())])
-> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. b -> NonEmpty (Pattern c b, [Atom c b]) -> Atom c b
Case StackType ()
ty (NonEmpty
   (Pattern (ConsAnn (StackType ())) (StackType ()),
    [Atom (ConsAnn (StackType ())) (StackType ())])
 -> Atom (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     (NonEmpty
        (Pattern (ConsAnn (StackType ())) (StackType ()),
         [Atom (ConsAnn (StackType ())) (StackType ())]))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Pattern (StackType ()) (StackType ()),
  [Atom (StackType ()) (StackType ())])
 -> MonoM
      (Pattern (ConsAnn (StackType ())) (StackType ()),
       [Atom (ConsAnn (StackType ())) (StackType ())]))
-> NonEmpty
     (Pattern (StackType ()) (StackType ()),
      [Atom (StackType ()) (StackType ())])
-> StateT
     RenameEnv
     (Either (Error ()))
     (NonEmpty
        (Pattern (ConsAnn (StackType ())) (StackType ()),
         [Atom (ConsAnn (StackType ())) (StackType ())]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Pattern (StackType ()) (StackType ()),
 [Atom (StackType ()) (StackType ())])
-> MonoM
     (Pattern (ConsAnn (StackType ())) (StackType ()),
      [Atom (ConsAnn (StackType ())) (StackType ())])
renameCase NonEmpty
  (Pattern (StackType ()) (StackType ()),
   [Atom (StackType ()) (StackType ())])
ls
renameAtom (AtCons StackType ()
ty (Name Text
t Unique
u StackType ()
_)) = do
    Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
cSt <- (RenameEnv
 -> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
consEnv
    let (Unique
u', ConsAnn (StackType ())
ann) = (Unique, ConsAnn (StackType ()))
-> (Unique, StackType ())
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> (Unique, ConsAnn (StackType ()))
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Char] -> (Unique, ConsAnn (StackType ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error? unfound constructor") (Unique
u, StackType ()
ty) Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
cSt
    Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom (ConsAnn (StackType ())) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> Atom (ConsAnn (StackType ())) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ ConsAnn (StackType ())
-> TyName (ConsAnn (StackType ()))
-> Atom (ConsAnn (StackType ())) (StackType ())
forall c b. c -> TyName c -> Atom c b
AtCons ConsAnn (StackType ())
ann (Text
-> Unique
-> ConsAnn (StackType ())
-> TyName (ConsAnn (StackType ()))
forall a. Text -> Unique -> a -> Name a
Name Text
t Unique
u' ConsAnn (StackType ())
ann)

renameDecl :: KempeDecl () (StackType ()) (StackType ()) -> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
renameDecl :: KempeDecl () (StackType ()) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
renameDecl (FunDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
is [KempeTy ()]
os [Atom (StackType ()) (StackType ())]
as) = StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> [Atom (ConsAnn (StackType ())) (StackType ())]
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
forall a c b.
b
-> Name b
-> [KempeTy a]
-> [KempeTy a]
-> [Atom c b]
-> KempeDecl a c b
FunDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
is [KempeTy ()]
os ([Atom (ConsAnn (StackType ())) (StackType ())]
 -> KempeDecl () (ConsAnn (StackType ())) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn (StackType ())) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn (StackType ())) (StackType ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Atom (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Atom (ConsAnn (StackType ())) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as
renameDecl (Export StackType ()
ty ABI
abi (Name Text
t Unique
u StackType ()
l)) = do
    Map (Unique, StackType ()) Unique
mSt <- (RenameEnv -> Map (Unique, StackType ()) Unique)
-> StateT
     RenameEnv (Either (Error ())) (Map (Unique, StackType ()) Unique)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv -> Map (Unique, StackType ()) Unique
fnEnv
    let u' :: Unique
u' = Unique
-> (Unique, StackType ())
-> Map (Unique, StackType ()) Unique
-> Unique
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Char] -> Unique
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen; might be user error or internal error") (Unique
u, StackType ()
ty) Map (Unique, StackType ()) Unique
mSt
    KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn (StackType ())) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ())))
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> ABI
-> Name (StackType ())
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
forall a c b. b -> ABI -> Name b -> KempeDecl a c b
Export StackType ()
ty ABI
abi (Text -> Unique -> StackType () -> Name (StackType ())
forall a. Text -> Unique -> a -> Name a
Name Text
t Unique
u' StackType ()
l)
renameDecl (ExtFnDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
tys [KempeTy ()]
tys' ByteString
b) = KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn (StackType ())) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ())))
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> ByteString
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
forall a c b.
b
-> Name b
-> [KempeTy a]
-> [KempeTy a]
-> ByteString
-> KempeDecl a c b
ExtFnDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
tys [KempeTy ()]
tys' ByteString
b
renameDecl (TyDecl ()
l Name ()
n [Name ()]
vars [(Name (StackType ()), [KempeTy ()])]
ls)       = KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn (StackType ())) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ())))
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
forall a b. (a -> b) -> a -> b
$ ()
-> Name ()
-> [Name ()]
-> [(Name (StackType ()), [KempeTy ()])]
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
forall a c b.
a
-> TyName a
-> [TyName a]
-> [(Name b, [KempeTy a])]
-> KempeDecl a c b
TyDecl ()
l Name ()
n [Name ()]
vars [(Name (StackType ()), [KempeTy ()])]
ls

-- | Call 'closedModule' and perform any necessary renamings
flattenModule :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
flattenModule :: Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
flattenModule = Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
renameMonoM (Module () (StackType ()) (StackType ())
 -> MonoM (Module () (ConsAnn (StackType ())) (StackType ())))
-> (Module () (StackType ()) (StackType ())
    -> StateT
         RenameEnv
         (Either (Error ()))
         (Module () (StackType ()) (StackType ())))
-> Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Module () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
closedModule

-- | To be called after 'closedModule'
renameMonoM :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
renameMonoM :: Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
renameMonoM = (KempeDecl () (StackType ()) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ())))
-> Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KempeDecl () (StackType ()) (StackType ())
-> MonoM (KempeDecl () (ConsAnn (StackType ())) (StackType ()))
renameDecl

-- | Filter so that only the 'KempeDecl's necessary for exports are there, and
-- fan out top-level functions into all necessary specializations.
--
-- This will throw an exception on ill-typed programs.
--
-- The 'Module' returned will have to be renamed.
closedModule :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (StackType ()) (StackType ()))
closedModule :: Module () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
closedModule Module () (StackType ()) (StackType ())
m = Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
addExports (Module () (StackType ()) (StackType ())
 -> Module () (StackType ()) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    { Module () (StackType ()) (StackType ())
fn' <- ((Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> [(Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((KempeDecl () (StackType ()) (StackType ())
 -> StackType ()
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> (KempeDecl () (StackType ()) (StackType ()), StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KempeDecl () (StackType ()) (StackType ())
-> StackType ()
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
specializeDecl ((KempeDecl () (StackType ()) (StackType ()), StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> ((Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())
    -> (KempeDecl () (StackType ()) (StackType ()), StackType ()))
-> (Name (StackType ()),
    KempeDecl () (StackType ()) (StackType ()), StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
 StackType ())
-> (KempeDecl () (StackType ()) (StackType ()), StackType ())
forall a a b. (a, a, b) -> (a, b)
drop1) [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
fnDecls
    ; Module () (StackType ()) (StackType ())
ty' <- [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
specializeTyDecls [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
tyDecls
    ; Module () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module () (StackType ()) (StackType ())
ty' Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
forall a. [a] -> [a] -> [a]
++ Module () (StackType ()) (StackType ())
fn')
    }
    where addExports :: Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
addExports = (Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
forall a. [a] -> [a] -> [a]
++ Module () (StackType ()) (StackType ())
-> Module () (StackType ()) (StackType ())
forall a c b. Module a c b -> Module a c b
exportsOnly Module () (StackType ()) (StackType ())
m)
          key :: ModuleMap () (StackType ()) (StackType ())
key = Module () (StackType ()) (StackType ())
-> ModuleMap () (StackType ()) (StackType ())
forall a c b. Module a c b -> ModuleMap a c b
mkModuleMap Module () (StackType ()) (StackType ())
m
          roots :: [(Name (StackType ()), StackType ())]
roots = Set (Name (StackType ()), StackType ())
-> [(Name (StackType ()), StackType ())]
forall a. Set a -> [a]
S.toList (Set (Name (StackType ()), StackType ())
 -> [(Name (StackType ()), StackType ())])
-> Set (Name (StackType ()), StackType ())
-> [(Name (StackType ()), StackType ())]
forall a b. (a -> b) -> a -> b
$ (Module () (StackType ()) (StackType ()),
 ModuleMap () (StackType ()) (StackType ()))
-> Set (Name (StackType ()), StackType ())
forall b a.
Ord b =>
(Module a b b, ModuleMap a b b) -> Set (Name b, b)
closure (Module () (StackType ()) (StackType ())
m, ModuleMap () (StackType ()) (StackType ())
key)
          gatherDecl :: (Name a, c)
-> (Name a, KempeDecl () (StackType ()) (StackType ()), c)
gatherDecl (n :: Name a
n@(Name Text
_ (Unique Int
i) a
_), c
ty) = -- TODO: findWithDefault?
            case Int
-> ModuleMap () (StackType ()) (StackType ())
-> Maybe (KempeDecl () (StackType ()) (StackType ()))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i ModuleMap () (StackType ()) (StackType ())
key of
                Just KempeDecl () (StackType ()) (StackType ())
decl -> (Name a
n, KempeDecl () (StackType ()) (StackType ())
decl, c
ty)
                Maybe (KempeDecl () (StackType ()) (StackType ()))
Nothing   -> [Char] -> (Name a, KempeDecl () (StackType ()) (StackType ()), c)
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error! module map should contain all names."
          rootDecl :: [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
rootDecl = (Name (StackType ()), StackType ())
-> (Name (StackType ()),
    KempeDecl () (StackType ()) (StackType ()), StackType ())
forall a c.
(Name a, c)
-> (Name a, KempeDecl () (StackType ()) (StackType ()), c)
gatherDecl ((Name (StackType ()), StackType ())
 -> (Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ()))
-> [(Name (StackType ()), StackType ())]
-> [(Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name (StackType ()), StackType ())]
roots -- FIXME: two-steps away, the roots are not monomorphized! So it tries to create specialized declarations of type a b -- a b a &c.
          drop1 :: (a, a, b) -> (a, b)
drop1 ~(a
_, a
y, b
z) = (a
y, b
z)
          ([(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
tyDecls, [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
fnDecls) = ((Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())
 -> Bool)
-> [(Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())]
-> ([(Name (StackType ()),
      KempeDecl () (StackType ()) (StackType ()), StackType ())],
    [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
      StackType ())])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (KempeDecl () (StackType ()) (StackType ()) -> Bool
forall a c b. KempeDecl a c b -> Bool
isTyDecl (KempeDecl () (StackType ()) (StackType ()) -> Bool)
-> ((Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())
    -> KempeDecl () (StackType ()) (StackType ()))
-> (Name (StackType ()),
    KempeDecl () (StackType ()) (StackType ()), StackType ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
 StackType ())
-> KempeDecl () (StackType ()) (StackType ())
forall a b c. (a, b, c) -> b
snd3) [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
rootDecl
          isTyDecl :: KempeDecl a c b -> Bool
isTyDecl TyDecl{} = Bool
True
          isTyDecl KempeDecl a c b
_        = Bool
False

-- group specializations by type name?
specializeTyDecls :: [(TyName (StackType ()), KempeDecl () (StackType ()) (StackType ()), StackType ())] -> MonoM [KempeDecl () (StackType ()) (StackType ())]
specializeTyDecls :: [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
specializeTyDecls [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
ds = ((KempeDecl () (StackType ()) (StackType ()),
  [(Name (StackType ()), StackType ())])
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> [(KempeDecl () (StackType ()) (StackType ()),
     [(Name (StackType ()), StackType ())])]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Module () (StackType ()) (StackType ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((KempeDecl () (StackType ()) (StackType ())
 -> [(Name (StackType ()), StackType ())]
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> (KempeDecl () (StackType ()) (StackType ()),
    [(Name (StackType ()), StackType ())])
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KempeDecl () (StackType ()) (StackType ())
-> [(Name (StackType ()), StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
mkTyDecl) [(KempeDecl () (StackType ()) (StackType ()),
  [(Name (StackType ()), StackType ())])]
processed
    where toMerge :: [[(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
   StackType ())]]
toMerge = ((Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())
 -> (Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())
 -> Bool)
-> [(Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())]
-> [[(Name (StackType ()),
      KempeDecl () (StackType ()) (StackType ()), StackType ())]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (KempeDecl () (StackType ()) (StackType ())
-> KempeDecl () (StackType ()) (StackType ()) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (KempeDecl () (StackType ()) (StackType ())
 -> KempeDecl () (StackType ()) (StackType ()) -> Bool)
-> ((Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())
    -> KempeDecl () (StackType ()) (StackType ()))
-> (Name (StackType ()),
    KempeDecl () (StackType ()) (StackType ()), StackType ())
-> (Name (StackType ()),
    KempeDecl () (StackType ()) (StackType ()), StackType ())
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
 StackType ())
-> KempeDecl () (StackType ()) (StackType ())
forall a b c. (a, b, c) -> b
snd3) [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
ds
          processed :: [(KempeDecl () (StackType ()) (StackType ()),
  [(Name (StackType ()), StackType ())])]
processed = ([(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
   StackType ())]
 -> (KempeDecl () (StackType ()) (StackType ()),
     [(Name (StackType ()), StackType ())]))
-> [[(Name (StackType ()),
      KempeDecl () (StackType ()) (StackType ()), StackType ())]]
-> [(KempeDecl () (StackType ()) (StackType ()),
     [(Name (StackType ()), StackType ())])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
-> (KempeDecl () (StackType ()) (StackType ()),
    [(Name (StackType ()), StackType ())])
forall a b b. [(a, b, b)] -> (b, [(a, b)])
process [[(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
   StackType ())]]
toMerge
          process :: [(a, b, b)] -> (b, [(a, b)])
process tyDs :: [(a, b, b)]
tyDs@((a
_, b
x, b
_):[(a, b, b)]
_) = (b
x, [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a, b, b) -> a
forall a b c. (a, b, c) -> a
fst3 ((a, b, b) -> a) -> [(a, b, b)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b, b)]
tyDs) ((a, b, b) -> b
forall a b c. (a, b, c) -> c
thd3 ((a, b, b) -> b) -> [(a, b, b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b, b)]
tyDs))
          process []                 = [Char] -> (b, [(a, b)])
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty group!"

mkTyDecl :: KempeDecl () (StackType ()) (StackType ()) -> [(TyName (StackType ()), StackType ())] -> MonoM (KempeDecl () (StackType ()) (StackType ()))
mkTyDecl :: KempeDecl () (StackType ()) (StackType ())
-> [(Name (StackType ()), StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
mkTyDecl (TyDecl ()
_ Name ()
tn [Name ()]
ns [(Name (StackType ()), [KempeTy ()])]
preConstrs) [(Name (StackType ()), StackType ())]
constrs = do
    [(Name (StackType ()), [KempeTy ()])]
renCons <- ((Name (StackType ()), StackType ())
 -> StateT
      RenameEnv (Either (Error ())) (Name (StackType ()), [KempeTy ()]))
-> [(Name (StackType ()), StackType ())]
-> StateT
     RenameEnv (Either (Error ())) [(Name (StackType ()), [KempeTy ()])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Name (StackType ())
tn', StackType ()
ty) -> do { ty' :: MonoStackType
ty'@([KempeTy ()]
is, [KempeTy ()]
_) <- StackType () -> StateT RenameEnv (Either (Error ())) MonoStackType
forall (m :: * -> *).
MonadError (Error ()) m =>
StackType () -> m MonoStackType
tryMono StackType ()
ty ; (, [KempeTy ()]
is) (Name (StackType ()) -> (Name (StackType ()), [KempeTy ()]))
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
-> StateT
     RenameEnv (Either (Error ())) (Name (StackType ()), [KempeTy ()])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyName MonoStackType
-> MonoStackType
-> (StackType () -> ConsAnn (StackType ()))
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall a.
TyName a
-> MonoStackType
-> (StackType () -> ConsAnn (StackType ()))
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
renamedCons (Name (StackType ())
tn' Name (StackType ()) -> MonoStackType -> TyName MonoStackType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> MonoStackType
ty') MonoStackType
ty' (Int64 -> Word8 -> StackType () -> ConsAnn (StackType ())
forall a. Int64 -> Word8 -> a -> ConsAnn a
ConsAnn (MonoStackType -> Int64
forall a a. (a, [KempeTy a]) -> Int64
szType MonoStackType
ty') (Name (StackType ()) -> Word8
forall a a. (Num a, Enum a) => Name a -> a
getTag Name (StackType ())
tn')) }) [(Name (StackType ()), StackType ())]
constrs
    KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ ()
-> Name ()
-> [Name ()]
-> [(Name (StackType ()), [KempeTy ()])]
-> KempeDecl () (StackType ()) (StackType ())
forall a c b.
a
-> TyName a
-> [TyName a]
-> [(Name b, [KempeTy a])]
-> KempeDecl a c b
TyDecl () Name ()
tn [Name ()]
ns [(Name (StackType ()), [KempeTy ()])]
renCons
    where indexAt :: (b -> Bool) -> [b] -> a
indexAt b -> Bool
p [b]
xs = (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (a, b) -> a
forall a b. (a -> b) -> a -> b
$ (a, b) -> Maybe (a, b) -> (a, b)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (a, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error.") (Maybe (a, b) -> (a, b)) -> Maybe (a, b) -> (a, b)
forall a b. (a -> b) -> a -> b
$ ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a
_, b
x) -> b -> Bool
p b
x) ([a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [b]
xs)
          getTag :: Name a -> a
getTag (Name Text
_ Unique
u a
_) = (Unique -> Bool) -> [Unique] -> a
forall a b. (Num a, Enum a) => (b -> Bool) -> [b] -> a
indexAt (Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
u) [Unique]
preIxes
          preIxes :: [Unique]
preIxes = ((Name (StackType ()), [KempeTy ()]) -> Unique)
-> [(Name (StackType ()), [KempeTy ()])] -> [Unique]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name (StackType ()) -> Unique
forall a. Name a -> Unique
unique (Name (StackType ()) -> Unique)
-> ((Name (StackType ()), [KempeTy ()]) -> Name (StackType ()))
-> (Name (StackType ()), [KempeTy ()])
-> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (StackType ()), [KempeTy ()]) -> Name (StackType ())
forall a b. (a, b) -> a
fst) [(Name (StackType ()), [KempeTy ()])]
preConstrs
          szType :: (a, [KempeTy a]) -> Int64
szType (a
_, [KempeTy a
o]) = Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ KempeTy a -> Int64
forall a. KempeTy a -> Int64
size KempeTy a
o
          szType (a, [KempeTy a])
_        = [Char] -> Int64
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: ill-typed constructor."
mkTyDecl KempeDecl () (StackType ()) (StackType ())
_ [(Name (StackType ()), StackType ())]
_ = [Char]
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen."

specializeDecl :: KempeDecl () (StackType ()) (StackType ()) -> StackType () -> MonoM (KempeDecl () (StackType ()) (StackType ()))
specializeDecl :: KempeDecl () (StackType ()) (StackType ())
-> StackType ()
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
specializeDecl (FunDecl StackType ()
_ Name (StackType ())
n [KempeTy ()]
_ [KempeTy ()]
_ [Atom (StackType ()) (StackType ())]
as) StackType ()
sty = do
    (Name Text
t Unique
u newStackType :: StackType ()
newStackType@(StackType Set (Name ())
_ [KempeTy ()]
is [KempeTy ()]
os)) <- Name (StackType ())
-> MonoStackType
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall a.
Name a
-> MonoStackType
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
renamed Name (StackType ())
n (MonoStackType
 -> StateT RenameEnv (Either (Error ())) (Name (StackType ())))
-> StateT RenameEnv (Either (Error ())) MonoStackType
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StackType () -> StateT RenameEnv (Either (Error ())) MonoStackType
forall (m :: * -> *).
MonadError (Error ()) m =>
StackType () -> m MonoStackType
tryMono StackType ()
sty
    KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> [Atom (StackType ()) (StackType ())]
-> KempeDecl () (StackType ()) (StackType ())
forall a c b.
b
-> Name b
-> [KempeTy a]
-> [KempeTy a]
-> [Atom c b]
-> KempeDecl a c b
FunDecl StackType ()
newStackType (Text -> Unique -> StackType () -> Name (StackType ())
forall a. Text -> Unique -> a -> Name a
Name Text
t Unique
u StackType ()
newStackType) [KempeTy ()]
is [KempeTy ()]
os [Atom (StackType ()) (StackType ())]
as
specializeDecl (ExtFnDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
tys [KempeTy ()]
tys' ByteString
b) StackType ()
_ = KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> ByteString
-> KempeDecl () (StackType ()) (StackType ())
forall a c b.
b
-> Name b
-> [KempeTy a]
-> [KempeTy a]
-> ByteString
-> KempeDecl a c b
ExtFnDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
tys [KempeTy ()]
tys' ByteString
b
specializeDecl (Export StackType ()
l ABI
abi Name (StackType ())
n) StackType ()
_           = KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (KempeDecl () (StackType ()) (StackType ())))
-> KempeDecl () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> ABI
-> Name (StackType ())
-> KempeDecl () (StackType ()) (StackType ())
forall a c b. b -> ABI -> Name b -> KempeDecl a c b
Export StackType ()
l ABI
abi Name (StackType ())
n
specializeDecl TyDecl{} StackType ()
_                   = [Char]
-> StateT
     RenameEnv
     (Either (Error ()))
     (KempeDecl () (StackType ()) (StackType ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen."
-- leave exports and foreign imports alone (have to be monomorphic)

renamedCons :: TyName a -> MonoStackType -> (StackType () -> ConsAnn (StackType ())) -> MonoM (TyName (StackType ()))
renamedCons :: TyName a
-> MonoStackType
-> (StackType () -> ConsAnn (StackType ()))
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
renamedCons (Name Text
t Unique
i a
_) sty :: MonoStackType
sty@([KempeTy ()]
is, [KempeTy ()]
os) StackType () -> ConsAnn (StackType ())
fAnn = do
    let t' :: Text
t' = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MonoStackType -> Text
squishMonoStackType MonoStackType
sty
    (Name Text
_ Unique
j MonoStackType
_) <- Text -> MonoStackType -> MonoM (TyName MonoStackType)
forall a. Text -> a -> MonoM (Name a)
freshName Text
t' MonoStackType
sty
    let newStackType :: StackType ()
newStackType = Set (Name ()) -> [KempeTy ()] -> [KempeTy ()] -> StackType ()
forall b. Set (Name b) -> [KempeTy b] -> [KempeTy b] -> StackType b
StackType Set (Name ())
forall a. Set a
S.empty [KempeTy ()]
is [KempeTy ()]
os
        ann :: ConsAnn (StackType ())
ann = StackType () -> ConsAnn (StackType ())
fAnn StackType ()
newStackType
    ASetter
  RenameEnv
  RenameEnv
  (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
  (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
-> (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
    -> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
-> StateT RenameEnv (Either (Error ())) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  RenameEnv
  RenameEnv
  (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
  (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
Lens'
  RenameEnv
  (Map (Unique, StackType ()) (Unique, ConsAnn (StackType ())))
consEnvLens ((Unique, StackType ())
-> (Unique, ConsAnn (StackType ()))
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
-> Map (Unique, StackType ()) (Unique, ConsAnn (StackType ()))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Unique
i, StackType ()
newStackType) (Unique
j, ConsAnn (StackType ())
ann))
    Name (StackType ())
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Unique -> StackType () -> Name (StackType ())
forall a. Text -> Unique -> a -> Name a
Name Text
t' Unique
j StackType ()
newStackType)

-- | Insert a specialized rename.
renamed :: Name a -> MonoStackType -> MonoM (Name (StackType ()))
renamed :: Name a
-> MonoStackType
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
renamed (Name Text
t Unique
i a
_) sty :: MonoStackType
sty@([KempeTy ()]
is, [KempeTy ()]
os) = do
    let t' :: Text
t' = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MonoStackType -> Text
squishMonoStackType MonoStackType
sty
    (Name Text
_ Unique
j MonoStackType
_) <- Text -> MonoStackType -> MonoM (TyName MonoStackType)
forall a. Text -> a -> MonoM (Name a)
freshName Text
t' MonoStackType
sty
    let newStackType :: StackType ()
newStackType = Set (Name ()) -> [KempeTy ()] -> [KempeTy ()] -> StackType ()
forall b. Set (Name b) -> [KempeTy b] -> [KempeTy b] -> StackType b
StackType Set (Name ())
forall a. Set a
S.empty [KempeTy ()]
is [KempeTy ()]
os
    ASetter
  RenameEnv
  RenameEnv
  (Map (Unique, StackType ()) Unique)
  (Map (Unique, StackType ()) Unique)
-> (Map (Unique, StackType ()) Unique
    -> Map (Unique, StackType ()) Unique)
-> StateT RenameEnv (Either (Error ())) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  RenameEnv
  RenameEnv
  (Map (Unique, StackType ()) Unique)
  (Map (Unique, StackType ()) Unique)
Lens' RenameEnv (Map (Unique, StackType ()) Unique)
fnEnvLens ((Unique, StackType ())
-> Unique
-> Map (Unique, StackType ()) Unique
-> Map (Unique, StackType ()) Unique
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Unique
i, StackType ()
newStackType) Unique
j)
    Name (StackType ())
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Unique -> StackType () -> Name (StackType ())
forall a. Text -> Unique -> a -> Name a
Name Text
t' Unique
j StackType ()
newStackType)

closure :: Ord b => (Module a b b, ModuleMap a b b) -> S.Set (Name b, b)
closure :: (Module a b b, ModuleMap a b b) -> Set (Name b, b)
closure (Module a b b
m, ModuleMap a b b
key) = Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
loop Set (Name b, b)
roots Set (Name b, b)
forall a. Set a
S.empty
    where roots :: Set (Name b, b)
roots = [(Name b, b)] -> Set (Name b, b)
forall a. Ord a => [a] -> Set a
S.fromList (Module a b b -> [(Name b, b)]
forall a c b. Module a c b -> [(Name b, b)]
exports Module a b b
m)
          loop :: Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
loop Set (Name b, b)
ns Set (Name b, b)
avoid =
            let res :: Set (Name b, b)
res = ((Name b, b) -> Set (Name b, b))
-> Set (Name b, b) -> Set (Name b, b)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Name b -> Set (Name b, b)
forall a. Name a -> Set (Name b, b)
step (Name b -> Set (Name b, b))
-> ((Name b, b) -> Name b) -> (Name b, b) -> Set (Name b, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name b, b) -> Name b
forall a b. (a, b) -> a
fst) (Set (Name b, b)
ns Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Name b, b)
avoid)
                in if Set (Name b, b)
res Set (Name b, b) -> Set (Name b, b) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Name b, b)
ns
                    then Set (Name b, b)
res
                    else Set (Name b, b)
ns Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
forall a. Semigroup a => a -> a -> a
<> Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
loop Set (Name b, b)
res (Set (Name b, b)
ns Set (Name b, b) -> Set (Name b, b) -> Set (Name b, b)
forall a. Semigroup a => a -> a -> a
<> Set (Name b, b)
avoid)
          step :: Name a -> Set (Name b, b)
step (Name Text
_ (Unique Int
i) a
_) =
            case Int -> ModuleMap a b b -> Maybe (KempeDecl a b b)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i ModuleMap a b b
key of
                Just KempeDecl a b b
decl -> KempeDecl a b b -> Set (Name b, b)
forall b a. Ord b => KempeDecl a b b -> Set (Name b, b)
namesInDecl KempeDecl a b b
decl
                Maybe (KempeDecl a b b)
Nothing   -> [Char] -> Set (Name b, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error! module map should contain all names."

namesInDecl :: Ord b => KempeDecl a b b -> S.Set (Name b, b)
namesInDecl :: KempeDecl a b b -> Set (Name b, b)
namesInDecl TyDecl{}             = Set (Name b, b)
forall a. Set a
S.empty
namesInDecl ExtFnDecl{}          = Set (Name b, b)
forall a. Set a
S.empty
namesInDecl Export{}             = Set (Name b, b)
forall a. Set a
S.empty
namesInDecl (FunDecl b
_ Name b
_ [KempeTy a]
_ [KempeTy a]
_ [Atom b b]
as) = (Atom b b -> Set (Name b, b)) -> [Atom b b] -> Set (Name b, b)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Atom b b -> Set (Name b, b)
forall a. Ord a => Atom a a -> Set (Name a, a)
namesInAtom [Atom b b]
as

namesInAtom :: Ord a => Atom a a -> S.Set (Name a, a)
namesInAtom :: Atom a a -> Set (Name a, a)
namesInAtom AtBuiltin{}                = Set (Name a, a)
forall a. Set a
S.empty
namesInAtom (If a
_ [Atom a a]
as [Atom a a]
as')              = (Atom a a -> Set (Name a, a)) -> [Atom a a] -> Set (Name a, a)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Atom a a -> Set (Name a, a)
forall a. Ord a => Atom a a -> Set (Name a, a)
namesInAtom [Atom a a]
as Set (Name a, a) -> Set (Name a, a) -> Set (Name a, a)
forall a. Semigroup a => a -> a -> a
<> (Atom a a -> Set (Name a, a)) -> [Atom a a] -> Set (Name a, a)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Atom a a -> Set (Name a, a)
forall a. Ord a => Atom a a -> Set (Name a, a)
namesInAtom [Atom a a]
as'
namesInAtom (Dip a
_ [Atom a a]
as)                 = (Atom a a -> Set (Name a, a)) -> [Atom a a] -> Set (Name a, a)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Atom a a -> Set (Name a, a)
forall a. Ord a => Atom a a -> Set (Name a, a)
namesInAtom [Atom a a]
as
namesInAtom (AtName a
_ n :: Name a
n@(Name Text
_ Unique
_ a
l))  = (Name a, a) -> Set (Name a, a)
forall a. a -> Set a
S.singleton (Name a
n, a
l)
namesInAtom (AtCons a
_ tn :: Name a
tn@(Name Text
_ Unique
_ a
l)) = (Name a, a) -> Set (Name a, a)
forall a. a -> Set a
S.singleton (Name a
tn, a
l)
namesInAtom IntLit{}                   = Set (Name a, a)
forall a. Set a
S.empty
namesInAtom BoolLit{}                  = Set (Name a, a)
forall a. Set a
S.empty
namesInAtom Int8Lit{}                  = Set (Name a, a)
forall a. Set a
S.empty
namesInAtom WordLit{}                  = Set (Name a, a)
forall a. Set a
S.empty
namesInAtom (Case a
_ NonEmpty (Pattern a a, [Atom a a])
as)                = (Atom a a -> Set (Name a, a)) -> [Atom a a] -> Set (Name a, a)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Atom a a -> Set (Name a, a)
forall a. Ord a => Atom a a -> Set (Name a, a)
namesInAtom (((Pattern a a, [Atom a a]) -> [Atom a a])
-> NonEmpty (Pattern a a, [Atom a a]) -> [Atom a a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Pattern a a, [Atom a a]) -> [Atom a a]
forall a b. (a, b) -> b
snd NonEmpty (Pattern a a, [Atom a a])
as) -- FIXME: patterns too

exports :: Module a c b -> [(Name b, b)]
exports :: Module a c b -> [(Name b, b)]
exports = (KempeDecl a c b -> Maybe (Name b, b))
-> Module a c b -> [(Name b, b)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe KempeDecl a c b -> Maybe (Name b, b)
forall a c b. KempeDecl a c b -> Maybe (Name b, b)
exportsDecl

exportsOnly :: Module a c b -> Module a c b
exportsOnly :: Module a c b -> Module a c b
exportsOnly = (KempeDecl a c b -> Maybe (KempeDecl a c b))
-> Module a c b -> Module a c b
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe KempeDecl a c b -> Maybe (KempeDecl a c b)
forall a c b. KempeDecl a c b -> Maybe (KempeDecl a c b)
getExport where
    getExport :: KempeDecl a c b -> Maybe (KempeDecl a c b)
getExport d :: KempeDecl a c b
d@Export{} = KempeDecl a c b -> Maybe (KempeDecl a c b)
forall a. a -> Maybe a
Just KempeDecl a c b
d
    getExport KempeDecl a c b
_          = Maybe (KempeDecl a c b)
forall a. Maybe a
Nothing

exportsDecl :: KempeDecl a c b -> Maybe (Name b, b)
exportsDecl :: KempeDecl a c b -> Maybe (Name b, b)
exportsDecl (Export b
_ ABI
_ n :: Name b
n@(Name Text
_ Unique
_ b
l)) = (Name b, b) -> Maybe (Name b, b)
forall a. a -> Maybe a
Just (Name b
n, b
l)
exportsDecl KempeDecl a c b
_                           = Maybe (Name b, b)
forall a. Maybe a
Nothing