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

-- | This module is kind of half-assed. I don't have any references and it
-- depends on the inliner.
module Kempe.Monomorphize ( closedModule
                          , MonoM
                          , runMonoM
                          , flattenModule
                          , tryMono
                          , ConsAnn (..)
                          -- * Benchmark
                          , closure
                          , mkModuleMap
                          ) where

import           Control.Arrow              ((&&&))
import           Control.Monad              ((<=<))
import           Control.Monad.Except       (MonadError, throwError)
import           Control.Monad.State.Strict (StateT, gets, runStateT)
import           Data.Bifunctor             (second)
import           Data.Containers.ListUtils  (nubOrd)
import           Data.Foldable              (traverse_)
import           Data.Function              (on)
import           Data.Functor               (($>))
import qualified Data.IntMap                as IM
import           Data.List                  (elemIndex, find, groupBy, partition)
import qualified Data.Map                   as M
import           Data.Maybe                 (fromMaybe, mapMaybe)
import           Data.Semigroup             ((<>))
import qualified Data.Set                   as S
import qualified Data.Text                  as T
import           Data.Tuple                 (swap)
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 MonoStackType)
consEnv  :: M.Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
                           , RenameEnv -> SizeEnv
szEnv    :: SizeEnv
                           }

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 MonoStackType))
consEnvLens :: (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
 -> f (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)))
-> RenameEnv -> f RenameEnv
consEnvLens Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
-> f (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
f RenameEnv
s = (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
 -> RenameEnv)
-> f (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
-> f RenameEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
x -> RenameEnv
s { consEnv :: Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
consEnv = Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
x }) (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
-> f (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
f (RenameEnv
-> Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
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))

szEnvLens :: Lens' RenameEnv SizeEnv
szEnvLens :: (SizeEnv -> f SizeEnv) -> RenameEnv -> f RenameEnv
szEnvLens SizeEnv -> f SizeEnv
f RenameEnv
s = (SizeEnv -> RenameEnv) -> f SizeEnv -> f RenameEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\SizeEnv
x -> RenameEnv
s { szEnv :: SizeEnv
szEnv = SizeEnv
x }) (SizeEnv -> f SizeEnv
f (RenameEnv -> SizeEnv
szEnv RenameEnv
s))

runMonoM :: Int -> MonoM a -> Either (Error ()) (a, (Int, SizeEnv))
runMonoM :: Int -> MonoM a -> Either (Error ()) (a, (Int, SizeEnv))
runMonoM Int
maxI = ((a, RenameEnv) -> (a, (Int, SizeEnv)))
-> Either (Error ()) (a, RenameEnv)
-> Either (Error ()) (a, (Int, SizeEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RenameEnv -> (Int, SizeEnv))
-> (a, RenameEnv) -> (a, (Int, SizeEnv))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RenameEnv -> Int
maxState (RenameEnv -> Int)
-> (RenameEnv -> SizeEnv) -> RenameEnv -> (Int, SizeEnv)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& RenameEnv -> SizeEnv
szEnv)) (Either (Error ()) (a, RenameEnv)
 -> Either (Error ()) (a, (Int, SizeEnv)))
-> (MonoM a -> Either (Error ()) (a, RenameEnv))
-> MonoM a
-> Either (Error ()) (a, (Int, SizeEnv))
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 MonoStackType)
-> SizeEnv
-> RenameEnv
RenameEnv Int
maxI Map (Unique, StackType ()) Unique
forall a. Monoid a => a
mempty Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
forall a. Monoid a => a
mempty SizeEnv
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 ()

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

renameCase :: (Pattern (StackType ()) (StackType ()), [Atom (StackType ()) (StackType ())]) -> MonoM (Pattern (ConsAnn MonoStackType) (StackType ()), [Atom (ConsAnn MonoStackType) (StackType ())])
renameCase :: (Pattern (StackType ()) (StackType ()),
 [Atom (StackType ()) (StackType ())])
-> MonoM
     (Pattern (ConsAnn MonoStackType) (StackType ()),
      [Atom (ConsAnn MonoStackType) (StackType ())])
renameCase (Pattern (StackType ()) (StackType ())
p, [Atom (StackType ()) (StackType ())]
as) = (,) (Pattern (ConsAnn MonoStackType) (StackType ())
 -> [Atom (ConsAnn MonoStackType) (StackType ())]
 -> (Pattern (ConsAnn MonoStackType) (StackType ()),
     [Atom (ConsAnn MonoStackType) (StackType ())]))
-> MonoM (Pattern (ConsAnn MonoStackType) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     ([Atom (ConsAnn MonoStackType) (StackType ())]
      -> (Pattern (ConsAnn MonoStackType) (StackType ()),
          [Atom (ConsAnn MonoStackType) (StackType ())]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern (StackType ()) (StackType ())
-> MonoM (Pattern (ConsAnn MonoStackType) (StackType ()))
renamePattern Pattern (StackType ()) (StackType ())
p StateT
  RenameEnv
  (Either (Error ()))
  ([Atom (ConsAnn MonoStackType) (StackType ())]
   -> (Pattern (ConsAnn MonoStackType) (StackType ()),
       [Atom (ConsAnn MonoStackType) (StackType ())]))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn MonoStackType) (StackType ())]
-> MonoM
     (Pattern (ConsAnn MonoStackType) (StackType ()),
      [Atom (ConsAnn MonoStackType) (StackType ())])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn MonoStackType) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn MonoStackType) (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 MonoStackType) (StackType ()))
renameAtom [Atom (StackType ()) (StackType ())]
as

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

renameDecl :: KempeDecl () (StackType ()) (StackType ()) -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
renameDecl :: KempeDecl () (StackType ()) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
renameDecl (FunDecl StackType ()
l Name (StackType ())
n [KempeTy ()]
is [KempeTy ()]
os [Atom (StackType ()) (StackType ())]
as) = StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> [Atom (ConsAnn MonoStackType) (StackType ())]
-> KempeDecl () (ConsAnn MonoStackType) (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 MonoStackType) (StackType ())]
 -> KempeDecl () (ConsAnn MonoStackType) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn MonoStackType) (StackType ())]
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom (StackType ()) (StackType ())
 -> StateT
      RenameEnv
      (Either (Error ()))
      (Atom (ConsAnn MonoStackType) (StackType ())))
-> [Atom (StackType ()) (StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     [Atom (ConsAnn MonoStackType) (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 MonoStackType) (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 MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn MonoStackType) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ())))
-> KempeDecl () (ConsAnn MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> ABI
-> Name (StackType ())
-> KempeDecl () (ConsAnn MonoStackType) (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 MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn MonoStackType) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ())))
-> KempeDecl () (ConsAnn MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall a b. (a -> b) -> a -> b
$ StackType ()
-> Name (StackType ())
-> [KempeTy ()]
-> [KempeTy ()]
-> ByteString
-> KempeDecl () (ConsAnn MonoStackType) (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 MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KempeDecl () (ConsAnn MonoStackType) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ())))
-> KempeDecl () (ConsAnn MonoStackType) (StackType ())
-> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))
forall a b. (a -> b) -> a -> b
$ ()
-> Name ()
-> [Name ()]
-> [(Name (StackType ()), [KempeTy ()])]
-> KempeDecl () (ConsAnn MonoStackType) (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 :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
flattenModule :: Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
flattenModule = Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
renameMonoM (Declarations () (StackType ()) (StackType ())
 -> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ())))
-> (Declarations () (StackType ()) (StackType ())
    -> StateT
         RenameEnv
         (Either (Error ()))
         (Declarations () (StackType ()) (StackType ())))
-> Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Declarations () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
closedModule

-- | To be called after 'closedModule'
renameMonoM :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
renameMonoM :: Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
renameMonoM = (KempeDecl () (StackType ()) (StackType ())
 -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ())))
-> Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (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 MonoStackType) (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 :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (StackType ()) (StackType ()))
closedModule :: Declarations () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
closedModule Declarations () (StackType ()) (StackType ())
m = Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
addExports (Declarations () (StackType ()) (StackType ())
 -> Declarations () (StackType ()) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    { Declarations () (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 ()))
     (Declarations () (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
    ; (KempeDecl () (StackType ()) (StackType ())
 -> StateT RenameEnv (Either (Error ())) ())
-> Declarations () (StackType ()) (StackType ())
-> StateT RenameEnv (Either (Error ())) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ KempeDecl () (StackType ()) (StackType ())
-> StateT RenameEnv (Either (Error ())) ()
forall a c b.
KempeDecl a c b -> StateT RenameEnv (Either (Error ())) ()
insTyDecl (Declarations () (StackType ()) (StackType ())
 -> StateT RenameEnv (Either (Error ())) ())
-> Declarations () (StackType ()) (StackType ())
-> StateT RenameEnv (Either (Error ())) ()
forall a b. (a -> b) -> a -> b
$ Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
forall a. Ord a => [a] -> [a]
nubOrd ((Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
 StackType ())
-> KempeDecl () (StackType ()) (StackType ())
forall a b c. (a, b, c) -> b
snd3 ((Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())
 -> KempeDecl () (StackType ()) (StackType ()))
-> [(Name (StackType ()),
     KempeDecl () (StackType ()) (StackType ()), StackType ())]
-> Declarations () (StackType ()) (StackType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
tyDecls)
    ; Declarations () (StackType ()) (StackType ())
ty' <- [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
specializeTyDecls [(Name (StackType ()), KempeDecl () (StackType ()) (StackType ()),
  StackType ())]
tyDecls
    ; Declarations () (StackType ()) (StackType ())
-> StateT
     RenameEnv
     (Either (Error ()))
     (Declarations () (StackType ()) (StackType ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declarations () (StackType ()) (StackType ())
ty' Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
forall a. [a] -> [a] -> [a]
++ Declarations () (StackType ()) (StackType ())
fn')
    }
    where addExports :: Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
addExports = (Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
forall a. [a] -> [a] -> [a]
++ Declarations () (StackType ()) (StackType ())
-> Declarations () (StackType ()) (StackType ())
forall a c b. Declarations a c b -> Declarations a c b
exportsOnly Declarations () (StackType ()) (StackType ())
m)
          key :: ModuleMap () (StackType ()) (StackType ())
key = Declarations () (StackType ()) (StackType ())
-> ModuleMap () (StackType ()) (StackType ())
forall a c b. Declarations a c b -> ModuleMap a c b
mkModuleMap Declarations () (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
$ (Declarations () (StackType ()) (StackType ()),
 ModuleMap () (StackType ()) (StackType ()))
-> Set (Name (StackType ()), StackType ())
forall b a.
Ord b =>
(Declarations a b b, ModuleMap a b b) -> Set (Name b, b)
closure (Declarations () (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 ()))
     (Declarations () (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 ()))
     (Declarations () (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!"

isTyVar :: KempeTy a -> Bool
isTyVar :: KempeTy a -> Bool
isTyVar TyVar{} = Bool
True
isTyVar KempeTy a
_       = Bool
False

extrNames :: KempeTy a -> Name a
extrNames :: KempeTy a -> Name a
extrNames (TyVar a
_ Name a
n) = Name a
n
extrNames KempeTy a
_           = [Char] -> Name a
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error!"

sizeLeaf :: [Name a] -- ^ Type variables as declared
         -> [KempeTy a]
         -> MonoM Size
sizeLeaf :: [Name a] -> [KempeTy a] -> MonoM Size
sizeLeaf [Name a]
fv [KempeTy a]
tys = do
    { let ([KempeTy a]
tvs, [KempeTy a]
conc) = (KempeTy a -> Bool) -> [KempeTy a] -> ([KempeTy a], [KempeTy a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition KempeTy a -> Bool
forall a. KempeTy a -> Bool
isTyVar [KempeTy a]
tys
    ; Int64
pad <- SizeEnv -> [KempeTy a] -> Int64
forall a. SizeEnv -> [KempeTy a] -> Int64
sizeStack (SizeEnv -> [KempeTy a] -> Int64)
-> StateT RenameEnv (Either (Error ())) SizeEnv
-> StateT RenameEnv (Either (Error ())) ([KempeTy a] -> Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RenameEnv -> SizeEnv)
-> StateT RenameEnv (Either (Error ())) SizeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv -> SizeEnv
szEnv StateT RenameEnv (Either (Error ())) ([KempeTy a] -> Int64)
-> StateT RenameEnv (Either (Error ())) [KempeTy a]
-> StateT RenameEnv (Either (Error ())) Int64
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [KempeTy a] -> StateT RenameEnv (Either (Error ())) [KempeTy a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [KempeTy a]
conc
    ; let tvPrecompose :: [[a] -> a]
tvPrecompose = (KempeTy a -> [a] -> a) -> [KempeTy a] -> [[a] -> a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name a -> [a] -> a
forall a. Name a -> [a] -> a
forVar (Name a -> [a] -> a)
-> (KempeTy a -> Name a) -> KempeTy a -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KempeTy a -> Name a
forall a. KempeTy a -> Name a
extrNames) [KempeTy a]
tvs
    ; let tvComposed :: Size
tvComposed = (Size -> Size -> Size) -> Size -> [Size] -> Size
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Size -> Size -> Size
forall a t. Num a => (t -> a) -> (t -> a) -> t -> a
compose (Int64 -> Size
forall a b. a -> b -> a
const Int64
pad) [Size]
forall a. [[a] -> a]
tvPrecompose
    ; Size -> MonoM Size
forall (f :: * -> *) a. Applicative f => a -> f a
pure Size
tvComposed
    }
  where
    findIx :: Name a -> Int
findIx Name a
x = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: can't find index of type variable.") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Name a -> [Name a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name a
x [Name a]
fv
    forVar :: Name a -> [a] -> a
forVar Name a
n =
        let i :: Int
i = Name a -> Int
findIx Name a
n
            in ([a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i)
    compose :: (t -> a) -> (t -> a) -> t -> a
compose t -> a
sz t -> a
sz' = \t
tys' -> t -> a
sz t
tys' a -> a -> a
forall a. Num a => a -> a -> a
+ t -> a
sz' t
tys'

insTyDecl :: KempeDecl a c b -> MonoM ()
insTyDecl :: KempeDecl a c b -> StateT RenameEnv (Either (Error ())) ()
insTyDecl (TyDecl a
_ (Name Text
_ (Unique Int
k) a
_) [Name a]
fv [(TyName b, [KempeTy a])]
leaves) = do
    [Size]
leafSizes <- ([KempeTy a] -> MonoM Size)
-> [[KempeTy a]] -> StateT RenameEnv (Either (Error ())) [Size]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Name a] -> [KempeTy a] -> MonoM Size
forall a. [Name a] -> [KempeTy a] -> MonoM Size
sizeLeaf [Name a]
fv) (((TyName b, [KempeTy a]) -> [KempeTy a])
-> [(TyName b, [KempeTy a])] -> [[KempeTy a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyName b, [KempeTy a]) -> [KempeTy a]
forall a b. (a, b) -> b
snd [(TyName b, [KempeTy a])]
leaves)
    let consSz :: Size
consSz = \[Int64]
tys -> Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Size
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Size -> Size
forall a b. (a -> b) -> a -> b
$[Int64]
tys) (Size -> Int64) -> [Size] -> [Int64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Size]
leafSizes) -- for the tag
    ASetter RenameEnv RenameEnv SizeEnv SizeEnv
-> (SizeEnv -> SizeEnv) -> StateT RenameEnv (Either (Error ())) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter RenameEnv RenameEnv SizeEnv SizeEnv
Lens' RenameEnv SizeEnv
szEnvLens (Int -> Size -> SizeEnv -> SizeEnv
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k Size
consSz)
insTyDecl KempeDecl a c b
_ = [Char] -> StateT RenameEnv (Either (Error ())) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't happen."

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
    SizeEnv
env <- (RenameEnv -> SizeEnv)
-> StateT RenameEnv (Either (Error ())) SizeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenameEnv -> SizeEnv
szEnv
    [(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
-> (MonoStackType -> ConsAnn MonoStackType)
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
forall a.
TyName a
-> MonoStackType
-> (MonoStackType -> ConsAnn MonoStackType)
-> 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 -> MonoStackType -> ConsAnn MonoStackType
forall a. Int64 -> Word8 -> a -> ConsAnn a
ConsAnn (SizeEnv -> MonoStackType -> Int64
forall a a. SizeEnv -> (a, [KempeTy a]) -> Int64
szType SizeEnv
env 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 :: SizeEnv -> (a, [KempeTy a]) -> Int64
szType SizeEnv
env (a
_, [KempeTy a
o]) = SizeEnv -> KempeTy a -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env KempeTy a
o
          szType SizeEnv
_ (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 -> (MonoStackType -> ConsAnn MonoStackType) -> MonoM (TyName (StackType ()))
renamedCons :: TyName a
-> MonoStackType
-> (MonoStackType -> ConsAnn MonoStackType)
-> StateT RenameEnv (Either (Error ())) (Name (StackType ()))
renamedCons (Name Text
t Unique
i a
_) sty :: MonoStackType
sty@([KempeTy ()]
is, [KempeTy ()]
os) MonoStackType -> ConsAnn MonoStackType
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 MonoStackType
ann = MonoStackType -> ConsAnn MonoStackType
fAnn MonoStackType
sty
    ASetter
  RenameEnv
  RenameEnv
  (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
  (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
-> (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
    -> Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
-> 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 MonoStackType))
  (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
Lens'
  RenameEnv
  (Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))
consEnvLens ((Unique, StackType ())
-> (Unique, ConsAnn MonoStackType)
-> Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
-> Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Unique
i, StackType ()
newStackType) (Unique
j, ConsAnn MonoStackType
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 => (Declarations a b b, ModuleMap a b b) -> S.Set (Name b, b)
closure :: (Declarations a b b, ModuleMap a b b) -> Set (Name b, b)
closure (Declarations 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 (Declarations a b b -> [(Name b, b)]
forall a c b. Declarations a c b -> [(Name b, b)]
exports Declarations 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 :: Declarations a c b -> [(Name b, b)]
exports :: Declarations a c b -> [(Name b, b)]
exports = (KempeDecl a c b -> Maybe (Name b, b))
-> Declarations 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 :: Declarations a c b -> Declarations a c b
exportsOnly :: Declarations a c b -> Declarations a c b
exportsOnly = (KempeDecl a c b -> Maybe (KempeDecl a c b))
-> Declarations a c b -> Declarations 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