-- | Generating metadata so that programs can run at all.
module Futhark.Internalise.Entry
  ( entryPoint,
    VisibleTypes,
    visibleTypes,
  )
where

import Control.Monad
import Control.Monad.State
import Data.List (find, intersperse)
import Data.Map qualified as M
import Futhark.IR qualified as I
import Futhark.Internalise.TypesValues (internaliseSumTypeRep, internalisedTypeSize)
import Futhark.Util (chunks)
import Futhark.Util.Pretty (prettyTextOneLine)
import Language.Futhark qualified as E hiding (TypeArg)
import Language.Futhark.Core (Name, Uniqueness (..), VName, nameFromText)
import Language.Futhark.Semantic qualified as E

-- | The types that are visible to the outside world.
newtype VisibleTypes = VisibleTypes [E.TypeBind]

-- | Retrieve those type bindings that should be visible to the
-- outside world.  Currently that is everything at top level that does
-- not have type parameters.
visibleTypes :: E.Imports -> VisibleTypes
visibleTypes :: Imports -> VisibleTypes
visibleTypes = [TypeBind] -> VisibleTypes
VisibleTypes ([TypeBind] -> VisibleTypes)
-> (Imports -> [TypeBind]) -> Imports -> VisibleTypes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ImportName, FileModule) -> [TypeBind]) -> Imports -> [TypeBind]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (FileModule -> [TypeBind]
modTypes (FileModule -> [TypeBind])
-> ((ImportName, FileModule) -> FileModule)
-> (ImportName, FileModule)
-> [TypeBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, FileModule) -> FileModule
forall a b. (a, b) -> b
snd)
  where
    modTypes :: FileModule -> [TypeBind]
modTypes = ProgBase Info VName -> [TypeBind]
forall {f :: * -> *} {vn}. ProgBase f vn -> [TypeBindBase f vn]
progTypes (ProgBase Info VName -> [TypeBind])
-> (FileModule -> ProgBase Info VName) -> FileModule -> [TypeBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileModule -> ProgBase Info VName
E.fileProg
    progTypes :: ProgBase f vn -> [TypeBindBase f vn]
progTypes = (DecBase f vn -> [TypeBindBase f vn])
-> [DecBase f vn] -> [TypeBindBase f vn]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecBase f vn -> [TypeBindBase f vn]
forall {f :: * -> *} {vn}. DecBase f vn -> [TypeBindBase f vn]
decTypes ([DecBase f vn] -> [TypeBindBase f vn])
-> (ProgBase f vn -> [DecBase f vn])
-> ProgBase f vn
-> [TypeBindBase f vn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgBase f vn -> [DecBase f vn]
forall (f :: * -> *) vn. ProgBase f vn -> [DecBase f vn]
E.progDecs
    decTypes :: DecBase f vn -> [TypeBindBase f vn]
decTypes (E.TypeDec TypeBindBase f vn
tb) = [TypeBindBase f vn
tb]
    decTypes DecBase f vn
_ = []

findType :: VName -> VisibleTypes -> Maybe (E.TypeExp E.Info VName)
findType :: VName -> VisibleTypes -> Maybe (TypeExp Info VName)
findType VName
v (VisibleTypes [TypeBind]
ts) = TypeBind -> TypeExp Info VName
forall (f :: * -> *) vn. TypeBindBase f vn -> TypeExp f vn
E.typeExp (TypeBind -> TypeExp Info VName)
-> Maybe TypeBind -> Maybe (TypeExp Info VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeBind -> Bool) -> [TypeBind] -> Maybe TypeBind
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((VName -> VName -> Bool
forall a. Eq a => a -> a -> Bool
== VName
v) (VName -> Bool) -> (TypeBind -> VName) -> TypeBind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeBind -> VName
forall (f :: * -> *) vn. TypeBindBase f vn -> vn
E.typeAlias) [TypeBind]
ts

valueType :: I.TypeBase I.Rank Uniqueness -> I.ValueType
valueType :: TypeBase Rank Uniqueness -> ValueType
valueType (I.Prim PrimType
pt) = Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Signed (Int -> Rank
I.Rank Int
0) PrimType
pt
valueType (I.Array PrimType
pt Rank
rank Uniqueness
_) = Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Signed Rank
rank PrimType
pt
valueType I.Acc {} = [Char] -> ValueType
forall a. HasCallStack => [Char] -> a
error [Char]
"valueType Acc"
valueType I.Mem {} = [Char] -> ValueType
forall a. HasCallStack => [Char] -> a
error [Char]
"valueType Mem"

withoutDims :: E.TypeExp E.Info VName -> (Int, E.TypeExp E.Info VName)
withoutDims :: TypeExp Info VName -> (Int, TypeExp Info VName)
withoutDims (E.TEArray SizeExp Info VName
_ TypeExp Info VName
te SrcLoc
_) =
  let (Int
d, TypeExp Info VName
te') = TypeExp Info VName -> (Int, TypeExp Info VName)
withoutDims TypeExp Info VName
te
   in (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, TypeExp Info VName
te')
withoutDims TypeExp Info VName
te = (Int
0 :: Int, TypeExp Info VName
te)

rootType :: E.TypeExp E.Info VName -> E.TypeExp E.Info VName
rootType :: TypeExp Info VName -> TypeExp Info VName
rootType (E.TEApply TypeExp Info VName
te E.TypeArgExpSize {} SrcLoc
_) = TypeExp Info VName -> TypeExp Info VName
rootType TypeExp Info VName
te
rootType (E.TEUnique TypeExp Info VName
te SrcLoc
_) = TypeExp Info VName -> TypeExp Info VName
rootType TypeExp Info VName
te
rootType (E.TEDim [VName]
_ TypeExp Info VName
te SrcLoc
_) = TypeExp Info VName -> TypeExp Info VName
rootType TypeExp Info VName
te
rootType TypeExp Info VName
te = TypeExp Info VName
te

typeExpOpaqueName :: E.TypeExp E.Info VName -> Name
typeExpOpaqueName :: TypeExp Info VName -> Name
typeExpOpaqueName = Text -> Name
nameFromText (Text -> Name)
-> (TypeExp Info VName -> Text) -> TypeExp Info VName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeExp Info VName -> Text
f
  where
    f :: TypeExp Info VName -> Text
f = TypeExp Info VName -> Text
g (TypeExp Info VName -> Text)
-> (TypeExp Info VName -> TypeExp Info VName)
-> TypeExp Info VName
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeExp Info VName -> TypeExp Info VName
rootType
    g :: TypeExp Info VName -> Text
g (E.TEArray SizeExp Info VName
_ TypeExp Info VName
te SrcLoc
_) =
      let (Int
d, TypeExp Info VName
te') = TypeExp Info VName -> (Int, TypeExp Info VName)
withoutDims TypeExp Info VName
te
       in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) Text
"[]") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeExp Info VName -> Text
f TypeExp Info VName
te'
    g (E.TETuple [TypeExp Info VName]
tes SrcLoc
_) =
      Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " ((TypeExp Info VName -> Text) -> [TypeExp Info VName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp Info VName -> Text
f [TypeExp Info VName]
tes)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    g (E.TERecord [(Name, TypeExp Info VName)]
tes SrcLoc
_) =
      Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " (((Name, TypeExp Info VName) -> Text)
-> [(Name, TypeExp Info VName)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TypeExp Info VName) -> Text
onField [(Name, TypeExp Info VName)]
tes)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
      where
        onField :: (Name, TypeExp Info VName) -> Text
onField (Name
k, TypeExp Info VName
te) = Name -> Text
E.nameToText Name
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeExp Info VName -> Text
f TypeExp Info VName
te
    g (E.TESum [(Name, [TypeExp Info VName])]
cs SrcLoc
_) =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
" | " (((Name, [TypeExp Info VName]) -> Text)
-> [(Name, [TypeExp Info VName])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [TypeExp Info VName]) -> Text
onConstr [(Name, [TypeExp Info VName])]
cs))
      where
        onConstr :: (Name, [TypeExp Info VName]) -> Text
onConstr (Name
k, [TypeExp Info VName]
tes) =
          Name -> Text
E.nameToText Name
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
" " ((TypeExp Info VName -> Text) -> [TypeExp Info VName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp Info VName -> Text
f [TypeExp Info VName]
tes))
    g (E.TEParens TypeExp Info VName
te SrcLoc
_) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeExp Info VName -> Text
f TypeExp Info VName
te Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    g TypeExp Info VName
te = TypeExp Info VName -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine TypeExp Info VName
te

type GenOpaque = State I.OpaqueTypes

runGenOpaque :: GenOpaque a -> (a, I.OpaqueTypes)
runGenOpaque :: forall a. GenOpaque a -> (a, OpaqueTypes)
runGenOpaque = (GenOpaque a -> OpaqueTypes -> (a, OpaqueTypes))
-> OpaqueTypes -> GenOpaque a -> (a, OpaqueTypes)
forall a b c. (a -> b -> c) -> b -> a -> c
flip GenOpaque a -> OpaqueTypes -> (a, OpaqueTypes)
forall s a. State s a -> s -> (a, s)
runState OpaqueTypes
forall a. Monoid a => a
mempty

addType :: Name -> I.OpaqueType -> GenOpaque ()
addType :: Name -> OpaqueType -> GenOpaque ()
addType Name
name OpaqueType
t = (OpaqueTypes -> OpaqueTypes) -> GenOpaque ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OpaqueTypes -> OpaqueTypes) -> GenOpaque ())
-> (OpaqueTypes -> OpaqueTypes) -> GenOpaque ()
forall a b. (a -> b) -> a -> b
$ \(I.OpaqueTypes [(Name, OpaqueType)]
ts) ->
  case ((Name, OpaqueType) -> Bool)
-> [(Name, OpaqueType)] -> Maybe (Name, OpaqueType)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) (Name -> Bool)
-> ((Name, OpaqueType) -> Name) -> (Name, OpaqueType) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, OpaqueType) -> Name
forall a b. (a, b) -> a
fst) [(Name, OpaqueType)]
ts of
    Just (Name
_, OpaqueType
t')
      | OpaqueType
t OpaqueType -> OpaqueType -> Bool
forall a. Eq a => a -> a -> Bool
/= OpaqueType
t' ->
          [Char] -> OpaqueTypes
forall a. HasCallStack => [Char] -> a
error ([Char] -> OpaqueTypes) -> [Char] -> OpaqueTypes
forall a b. (a -> b) -> a -> b
$ [Char]
"Duplicate definition of entry point type " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
forall a. Pretty a => a -> [Char]
E.prettyString Name
name
    Maybe (Name, OpaqueType)
_ -> [(Name, OpaqueType)] -> OpaqueTypes
I.OpaqueTypes [(Name, OpaqueType)]
ts OpaqueTypes -> OpaqueTypes -> OpaqueTypes
forall a. Semigroup a => a -> a -> a
<> [(Name, OpaqueType)] -> OpaqueTypes
I.OpaqueTypes [(Name
name, OpaqueType
t)]

isRecord :: VisibleTypes -> E.TypeExp E.Info VName -> Maybe (M.Map Name (E.TypeExp E.Info VName))
isRecord :: VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName))
isRecord VisibleTypes
_ (E.TERecord [(Name, TypeExp Info VName)]
fs SrcLoc
_) = Map Name (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall a. a -> Maybe a
Just (Map Name (TypeExp Info VName)
 -> Maybe (Map Name (TypeExp Info VName)))
-> Map Name (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall a b. (a -> b) -> a -> b
$ [(Name, TypeExp Info VName)] -> Map Name (TypeExp Info VName)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TypeExp Info VName)]
fs
isRecord VisibleTypes
_ (E.TETuple [TypeExp Info VName]
fs SrcLoc
_) = Map Name (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall a. a -> Maybe a
Just (Map Name (TypeExp Info VName)
 -> Maybe (Map Name (TypeExp Info VName)))
-> Map Name (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall a b. (a -> b) -> a -> b
$ [TypeExp Info VName] -> Map Name (TypeExp Info VName)
forall a. [a] -> Map Name a
E.tupleFields [TypeExp Info VName]
fs
isRecord VisibleTypes
types (E.TEVar QualName VName
v SrcLoc
_) = VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName))
isRecord VisibleTypes
types (TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName)))
-> Maybe (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VName -> VisibleTypes -> Maybe (TypeExp Info VName)
findType (QualName VName -> VName
forall vn. QualName vn -> vn
E.qualLeaf QualName VName
v) VisibleTypes
types
isRecord VisibleTypes
_ TypeExp Info VName
_ = Maybe (Map Name (TypeExp Info VName))
forall a. Maybe a
Nothing

recordFields ::
  VisibleTypes ->
  M.Map Name E.StructType ->
  Maybe (E.TypeExp E.Info VName) ->
  [(Name, E.EntryType)]
recordFields :: VisibleTypes
-> Map Name StructType
-> Maybe (TypeExp Info VName)
-> [(Name, EntryType)]
recordFields VisibleTypes
types Map Name StructType
fs Maybe (TypeExp Info VName)
t =
  case VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName))
isRecord VisibleTypes
types (TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName)))
-> (TypeExp Info VName -> TypeExp Info VName)
-> TypeExp Info VName
-> Maybe (Map Name (TypeExp Info VName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeExp Info VName -> TypeExp Info VName
rootType (TypeExp Info VName -> Maybe (Map Name (TypeExp Info VName)))
-> Maybe (TypeExp Info VName)
-> Maybe (Map Name (TypeExp Info VName))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (TypeExp Info VName)
t of
    Just Map Name (TypeExp Info VName)
e_fs ->
      ((Name, StructType)
 -> (Name, TypeExp Info VName) -> (Name, EntryType))
-> [(Name, StructType)]
-> [(Name, TypeExp Info VName)]
-> [(Name, EntryType)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, StructType)
-> (Name, TypeExp Info VName) -> (Name, EntryType)
forall {a} {a}.
(a, StructType) -> (a, TypeExp Info VName) -> (a, EntryType)
f (Map Name StructType -> [(Name, StructType)]
forall a. Map Name a -> [(Name, a)]
E.sortFields Map Name StructType
fs) (Map Name (TypeExp Info VName) -> [(Name, TypeExp Info VName)]
forall a. Map Name a -> [(Name, a)]
E.sortFields Map Name (TypeExp Info VName)
e_fs)
      where
        f :: (a, StructType) -> (a, TypeExp Info VName) -> (a, EntryType)
f (a
k, StructType
f_t) (a
_, TypeExp Info VName
e_f_t) = (a
k, StructType -> Maybe (TypeExp Info VName) -> EntryType
E.EntryType StructType
f_t (Maybe (TypeExp Info VName) -> EntryType)
-> Maybe (TypeExp Info VName) -> EntryType
forall a b. (a -> b) -> a -> b
$ TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just TypeExp Info VName
e_f_t)
    Maybe (Map Name (TypeExp Info VName))
Nothing ->
      ((Name, StructType) -> (Name, EntryType))
-> [(Name, StructType)] -> [(Name, EntryType)]
forall a b. (a -> b) -> [a] -> [b]
map ((StructType -> EntryType)
-> (Name, StructType) -> (Name, EntryType)
forall a b. (a -> b) -> (Name, a) -> (Name, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StructType -> Maybe (TypeExp Info VName) -> EntryType
`E.EntryType` Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing)) ([(Name, StructType)] -> [(Name, EntryType)])
-> [(Name, StructType)] -> [(Name, EntryType)]
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> [(Name, StructType)]
forall a. Map Name a -> [(Name, a)]
E.sortFields Map Name StructType
fs

opaqueRecord ::
  VisibleTypes ->
  [(Name, E.EntryType)] ->
  [I.TypeBase I.Rank Uniqueness] ->
  GenOpaque [(Name, I.EntryPointType)]
opaqueRecord :: VisibleTypes
-> [(Name, EntryType)]
-> [TypeBase Rank Uniqueness]
-> GenOpaque [(Name, EntryPointType)]
opaqueRecord VisibleTypes
_ [] [TypeBase Rank Uniqueness]
_ = [(Name, EntryPointType)] -> GenOpaque [(Name, EntryPointType)]
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
opaqueRecord VisibleTypes
types ((Name
f, EntryType
t) : [(Name, EntryType)]
fs) [TypeBase Rank Uniqueness]
ts = do
  let ([TypeBase Rank Uniqueness]
f_ts, [TypeBase Rank Uniqueness]
ts') = Int
-> [TypeBase Rank Uniqueness]
-> ([TypeBase Rank Uniqueness], [TypeBase Rank Uniqueness])
forall a. Int -> [a] -> ([a], [a])
splitAt (StructType -> Int
forall als. TypeBase Size als -> Int
internalisedTypeSize (StructType -> Int) -> StructType -> Int
forall a b. (a -> b) -> a -> b
$ EntryType -> StructType
E.entryType EntryType
t) [TypeBase Rank Uniqueness]
ts
  EntryPointType
f' <- EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity EntryPointType
opaqueField EntryType
t [TypeBase Rank Uniqueness]
f_ts
  ((Name
f, EntryPointType
f') :) ([(Name, EntryPointType)] -> [(Name, EntryPointType)])
-> GenOpaque [(Name, EntryPointType)]
-> GenOpaque [(Name, EntryPointType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VisibleTypes
-> [(Name, EntryType)]
-> [TypeBase Rank Uniqueness]
-> GenOpaque [(Name, EntryPointType)]
opaqueRecord VisibleTypes
types [(Name, EntryType)]
fs [TypeBase Rank Uniqueness]
ts'
  where
    opaqueField :: EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity EntryPointType
opaqueField EntryType
e_t [TypeBase Rank Uniqueness]
i_ts = (Uniqueness, EntryPointType) -> EntryPointType
forall a b. (a, b) -> b
snd ((Uniqueness, EntryPointType) -> EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity EntryPointType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types EntryType
e_t [TypeBase Rank Uniqueness]
i_ts

isSum :: VisibleTypes -> E.TypeExp E.Info VName -> Maybe (M.Map Name [E.TypeExp E.Info VName])
isSum :: VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName])
isSum VisibleTypes
_ (E.TESum [(Name, [TypeExp Info VName])]
cs SrcLoc
_) = Map Name [TypeExp Info VName]
-> Maybe (Map Name [TypeExp Info VName])
forall a. a -> Maybe a
Just (Map Name [TypeExp Info VName]
 -> Maybe (Map Name [TypeExp Info VName]))
-> Map Name [TypeExp Info VName]
-> Maybe (Map Name [TypeExp Info VName])
forall a b. (a -> b) -> a -> b
$ [(Name, [TypeExp Info VName])] -> Map Name [TypeExp Info VName]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, [TypeExp Info VName])]
cs
isSum VisibleTypes
types (E.TEVar QualName VName
v SrcLoc
_) = VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName])
isSum VisibleTypes
types (TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName]))
-> Maybe (TypeExp Info VName)
-> Maybe (Map Name [TypeExp Info VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VName -> VisibleTypes -> Maybe (TypeExp Info VName)
findType (QualName VName -> VName
forall vn. QualName vn -> vn
E.qualLeaf QualName VName
v) VisibleTypes
types
isSum VisibleTypes
_ TypeExp Info VName
_ = Maybe (Map Name [TypeExp Info VName])
forall a. Maybe a
Nothing

sumConstrs ::
  VisibleTypes ->
  M.Map Name [E.StructType] ->
  Maybe (E.TypeExp E.Info VName) ->
  [(Name, [E.EntryType])]
sumConstrs :: VisibleTypes
-> Map Name [StructType]
-> Maybe (TypeExp Info VName)
-> [(Name, [EntryType])]
sumConstrs VisibleTypes
types Map Name [StructType]
cs Maybe (TypeExp Info VName)
t =
  case VisibleTypes
-> TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName])
isSum VisibleTypes
types (TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName]))
-> (TypeExp Info VName -> TypeExp Info VName)
-> TypeExp Info VName
-> Maybe (Map Name [TypeExp Info VName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeExp Info VName -> TypeExp Info VName
rootType (TypeExp Info VName -> Maybe (Map Name [TypeExp Info VName]))
-> Maybe (TypeExp Info VName)
-> Maybe (Map Name [TypeExp Info VName])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (TypeExp Info VName)
t of
    Just Map Name [TypeExp Info VName]
e_cs ->
      ((Name, [StructType])
 -> (Name, [TypeExp Info VName]) -> (Name, [EntryType]))
-> [(Name, [StructType])]
-> [(Name, [TypeExp Info VName])]
-> [(Name, [EntryType])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, [StructType])
-> (Name, [TypeExp Info VName]) -> (Name, [EntryType])
forall {a} {a}.
(a, [StructType]) -> (a, [TypeExp Info VName]) -> (a, [EntryType])
f (Map Name [StructType] -> [(Name, [StructType])]
forall a. Map Name a -> [(Name, a)]
E.sortConstrs Map Name [StructType]
cs) (Map Name [TypeExp Info VName] -> [(Name, [TypeExp Info VName])]
forall a. Map Name a -> [(Name, a)]
E.sortConstrs Map Name [TypeExp Info VName]
e_cs)
      where
        f :: (a, [StructType]) -> (a, [TypeExp Info VName]) -> (a, [EntryType])
f (a
k, [StructType]
c_ts) (a
_, [TypeExp Info VName]
e_c_ts) = (a
k, (StructType -> Maybe (TypeExp Info VName) -> EntryType)
-> [StructType] -> [Maybe (TypeExp Info VName)] -> [EntryType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith StructType -> Maybe (TypeExp Info VName) -> EntryType
E.EntryType [StructType]
c_ts ([Maybe (TypeExp Info VName)] -> [EntryType])
-> [Maybe (TypeExp Info VName)] -> [EntryType]
forall a b. (a -> b) -> a -> b
$ (TypeExp Info VName -> Maybe (TypeExp Info VName))
-> [TypeExp Info VName] -> [Maybe (TypeExp Info VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just [TypeExp Info VName]
e_c_ts)
    Maybe (Map Name [TypeExp Info VName])
Nothing ->
      ((Name, [StructType]) -> (Name, [EntryType]))
-> [(Name, [StructType])] -> [(Name, [EntryType])]
forall a b. (a -> b) -> [a] -> [b]
map (([StructType] -> [EntryType])
-> (Name, [StructType]) -> (Name, [EntryType])
forall a b. (a -> b) -> (Name, a) -> (Name, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StructType -> EntryType) -> [StructType] -> [EntryType]
forall a b. (a -> b) -> [a] -> [b]
map (StructType -> Maybe (TypeExp Info VName) -> EntryType
`E.EntryType` Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing))) ([(Name, [StructType])] -> [(Name, [EntryType])])
-> [(Name, [StructType])] -> [(Name, [EntryType])]
forall a b. (a -> b) -> a -> b
$ Map Name [StructType] -> [(Name, [StructType])]
forall a. Map Name a -> [(Name, a)]
E.sortConstrs Map Name [StructType]
cs

opaqueSum ::
  VisibleTypes ->
  [(Name, ([E.EntryType], [Int]))] ->
  [I.TypeBase I.Rank Uniqueness] ->
  GenOpaque [(Name, [(I.EntryPointType, [Int])])]
opaqueSum :: VisibleTypes
-> [(Name, ([EntryType], [Int]))]
-> [TypeBase Rank Uniqueness]
-> GenOpaque [(Name, [(EntryPointType, [Int])])]
opaqueSum VisibleTypes
types [(Name, ([EntryType], [Int]))]
cs [TypeBase Rank Uniqueness]
ts = ((Name, ([EntryType], [Int]))
 -> StateT OpaqueTypes Identity (Name, [(EntryPointType, [Int])]))
-> [(Name, ([EntryType], [Int]))]
-> GenOpaque [(Name, [(EntryPointType, [Int])])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((([EntryType], [Int])
 -> StateT OpaqueTypes Identity [(EntryPointType, [Int])])
-> (Name, ([EntryType], [Int]))
-> StateT OpaqueTypes Identity (Name, [(EntryPointType, [Int])])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Name, a) -> f (Name, b)
traverse ([EntryType], [Int])
-> StateT OpaqueTypes Identity [(EntryPointType, [Int])]
f) [(Name, ([EntryType], [Int]))]
cs
  where
    f :: ([EntryType], [Int])
-> StateT OpaqueTypes Identity [(EntryPointType, [Int])]
f ([EntryType]
ets, [Int]
is) = do
      let ns :: [Int]
ns = (EntryType -> Int) -> [EntryType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (StructType -> Int
forall als. TypeBase Size als -> Int
internalisedTypeSize (StructType -> Int)
-> (EntryType -> StructType) -> EntryType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryType -> StructType
E.entryType) [EntryType]
ets
          is' :: [[Int]]
is' = [Int] -> [Int] -> [[Int]]
forall a. [Int] -> [a] -> [[a]]
chunks [Int]
ns [Int]
is
      [EntryPointType]
ets' <- ((Uniqueness, EntryPointType) -> EntryPointType)
-> [(Uniqueness, EntryPointType)] -> [EntryPointType]
forall a b. (a -> b) -> [a] -> [b]
map (Uniqueness, EntryPointType) -> EntryPointType
forall a b. (a, b) -> b
snd ([(Uniqueness, EntryPointType)] -> [EntryPointType])
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
-> StateT OpaqueTypes Identity [EntryPointType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EntryType
 -> [TypeBase Rank Uniqueness]
 -> StateT OpaqueTypes Identity (Uniqueness, EntryPointType))
-> [EntryType]
-> [[TypeBase Rank Uniqueness]]
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types) [EntryType]
ets (([Int] -> [TypeBase Rank Uniqueness])
-> [[Int]] -> [[TypeBase Rank Uniqueness]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> TypeBase Rank Uniqueness)
-> [Int] -> [TypeBase Rank Uniqueness]
forall a b. (a -> b) -> [a] -> [b]
map ([TypeBase Rank Uniqueness]
ts !!)) [[Int]]
is')
      [(EntryPointType, [Int])]
-> StateT OpaqueTypes Identity [(EntryPointType, [Int])]
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(EntryPointType, [Int])]
 -> StateT OpaqueTypes Identity [(EntryPointType, [Int])])
-> [(EntryPointType, [Int])]
-> StateT OpaqueTypes Identity [(EntryPointType, [Int])]
forall a b. (a -> b) -> a -> b
$ [EntryPointType] -> [[Int]] -> [(EntryPointType, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [EntryPointType]
ets' ([[Int]] -> [(EntryPointType, [Int])])
-> [[Int]] -> [(EntryPointType, [Int])]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [[Int]]
is' -- Adjust for tag.

entryPointType ::
  VisibleTypes ->
  E.EntryType ->
  [I.TypeBase I.Rank Uniqueness] ->
  GenOpaque (Uniqueness, I.EntryPointType)
entryPointType :: VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types EntryType
t [TypeBase Rank Uniqueness]
ts
  | E.Scalar (E.Prim E.Unsigned {}) <- EntryType -> StructType
E.entryType EntryType
t,
    [I.Prim PrimType
ts0] <- [TypeBase Rank Uniqueness]
ts =
      (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, ValueType -> EntryPointType
I.TypeTransparent (ValueType -> EntryPointType) -> ValueType -> EntryPointType
forall a b. (a -> b) -> a -> b
$ Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Unsigned (Int -> Rank
I.Rank Int
0) PrimType
ts0)
  | E.Array NoUniqueness
_ Shape Size
_ (E.Prim E.Unsigned {}) <- EntryType -> StructType
E.entryType EntryType
t,
    [I.Array PrimType
ts0 Rank
r Uniqueness
_] <- [TypeBase Rank Uniqueness]
ts =
      (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, ValueType -> EntryPointType
I.TypeTransparent (ValueType -> EntryPointType) -> ValueType -> EntryPointType
forall a b. (a -> b) -> a -> b
$ Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Unsigned Rank
r PrimType
ts0)
  | E.Scalar E.Prim {} <- EntryType -> StructType
E.entryType EntryType
t,
    [I.Prim PrimType
ts0] <- [TypeBase Rank Uniqueness]
ts =
      (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, ValueType -> EntryPointType
I.TypeTransparent (ValueType -> EntryPointType) -> ValueType -> EntryPointType
forall a b. (a -> b) -> a -> b
$ Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Signed (Int -> Rank
I.Rank Int
0) PrimType
ts0)
  | E.Array NoUniqueness
_ Shape Size
_ E.Prim {} <- EntryType -> StructType
E.entryType EntryType
t,
    [I.Array PrimType
ts0 Rank
r Uniqueness
_] <- [TypeBase Rank Uniqueness]
ts =
      (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, ValueType -> EntryPointType
I.TypeTransparent (ValueType -> EntryPointType) -> ValueType -> EntryPointType
forall a b. (a -> b) -> a -> b
$ Signedness -> Rank -> PrimType -> ValueType
I.ValueType Signedness
I.Signed Rank
r PrimType
ts0)
  | Bool
otherwise = do
      case EntryType -> StructType
E.entryType EntryType
t of
        E.Scalar (E.Record Map Name StructType
fs)
          | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> Bool
forall a. Map Name a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Name StructType
fs ->
              let fs' :: [(Name, EntryType)]
fs' = VisibleTypes
-> Map Name StructType
-> Maybe (TypeExp Info VName)
-> [(Name, EntryType)]
recordFields VisibleTypes
types Map Name StructType
fs (Maybe (TypeExp Info VName) -> [(Name, EntryType)])
-> Maybe (TypeExp Info VName) -> [(Name, EntryType)]
forall a b. (a -> b) -> a -> b
$ EntryType -> Maybe (TypeExp Info VName)
E.entryAscribed EntryType
t
               in Name -> OpaqueType -> GenOpaque ()
addType Name
desc (OpaqueType -> GenOpaque ())
-> ([(Name, EntryPointType)] -> OpaqueType)
-> [(Name, EntryPointType)]
-> GenOpaque ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, EntryPointType)] -> OpaqueType
I.OpaqueRecord ([(Name, EntryPointType)] -> GenOpaque ())
-> GenOpaque [(Name, EntryPointType)] -> GenOpaque ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VisibleTypes
-> [(Name, EntryType)]
-> [TypeBase Rank Uniqueness]
-> GenOpaque [(Name, EntryPointType)]
opaqueRecord VisibleTypes
types [(Name, EntryType)]
fs' [TypeBase Rank Uniqueness]
ts
        E.Scalar (E.Sum Map Name [StructType]
cs) -> do
          let ([TypeBase ExtShape Uniqueness]
_, [(Name, [Int])]
places) = Map Name [StructType]
-> ([TypeBase ExtShape Uniqueness], [(Name, [Int])])
internaliseSumTypeRep Map Name [StructType]
cs
              cs' :: [(Name, [EntryType])]
cs' = VisibleTypes
-> Map Name [StructType]
-> Maybe (TypeExp Info VName)
-> [(Name, [EntryType])]
sumConstrs VisibleTypes
types Map Name [StructType]
cs (Maybe (TypeExp Info VName) -> [(Name, [EntryType])])
-> Maybe (TypeExp Info VName) -> [(Name, [EntryType])]
forall a b. (a -> b) -> a -> b
$ EntryType -> Maybe (TypeExp Info VName)
E.entryAscribed EntryType
t
              cs'' :: [(Name, ([EntryType], [Int]))]
cs'' = [Name] -> [([EntryType], [Int])] -> [(Name, ([EntryType], [Int]))]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Name, [EntryType]) -> Name) -> [(Name, [EntryType])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [EntryType]) -> Name
forall a b. (a, b) -> a
fst [(Name, [EntryType])]
cs') ([[EntryType]] -> [[Int]] -> [([EntryType], [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Name, [EntryType]) -> [EntryType])
-> [(Name, [EntryType])] -> [[EntryType]]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [EntryType]) -> [EntryType]
forall a b. (a, b) -> b
snd [(Name, [EntryType])]
cs') (((Name, [Int]) -> [Int]) -> [(Name, [Int])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Int]) -> [Int]
forall a b. (a, b) -> b
snd [(Name, [Int])]
places))
          Name -> OpaqueType -> GenOpaque ()
addType Name
desc (OpaqueType -> GenOpaque ())
-> ([(Name, [(EntryPointType, [Int])])] -> OpaqueType)
-> [(Name, [(EntryPointType, [Int])])]
-> GenOpaque ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ValueType] -> [(Name, [(EntryPointType, [Int])])] -> OpaqueType
I.OpaqueSum ((TypeBase Rank Uniqueness -> ValueType)
-> [TypeBase Rank Uniqueness] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase Rank Uniqueness -> ValueType
valueType [TypeBase Rank Uniqueness]
ts)
            ([(Name, [(EntryPointType, [Int])])] -> GenOpaque ())
-> GenOpaque [(Name, [(EntryPointType, [Int])])] -> GenOpaque ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VisibleTypes
-> [(Name, ([EntryType], [Int]))]
-> [TypeBase Rank Uniqueness]
-> GenOpaque [(Name, [(EntryPointType, [Int])])]
opaqueSum VisibleTypes
types [(Name, ([EntryType], [Int]))]
cs'' (Int -> [TypeBase Rank Uniqueness] -> [TypeBase Rank Uniqueness]
forall a. Int -> [a] -> [a]
drop Int
1 [TypeBase Rank Uniqueness]
ts)
        StructType
_ -> Name -> OpaqueType -> GenOpaque ()
addType Name
desc (OpaqueType -> GenOpaque ()) -> OpaqueType -> GenOpaque ()
forall a b. (a -> b) -> a -> b
$ [ValueType] -> OpaqueType
I.OpaqueType ([ValueType] -> OpaqueType) -> [ValueType] -> OpaqueType
forall a b. (a -> b) -> a -> b
$ (TypeBase Rank Uniqueness -> ValueType)
-> [TypeBase Rank Uniqueness] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase Rank Uniqueness -> ValueType
valueType [TypeBase Rank Uniqueness]
ts
      (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
forall a. a -> StateT OpaqueTypes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, Name -> EntryPointType
I.TypeOpaque Name
desc)
  where
    u :: Uniqueness
u = (Uniqueness -> Uniqueness -> Uniqueness)
-> Uniqueness -> [Uniqueness] -> Uniqueness
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Uniqueness -> Uniqueness -> Uniqueness
forall a. Ord a => a -> a -> a
max Uniqueness
Nonunique ([Uniqueness] -> Uniqueness) -> [Uniqueness] -> Uniqueness
forall a b. (a -> b) -> a -> b
$ (TypeBase Rank Uniqueness -> Uniqueness)
-> [TypeBase Rank Uniqueness] -> [Uniqueness]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase Rank Uniqueness -> Uniqueness
forall shape. TypeBase shape Uniqueness -> Uniqueness
I.uniqueness [TypeBase Rank Uniqueness]
ts
    desc :: Name
desc =
      Name
-> (TypeExp Info VName -> Name)
-> Maybe (TypeExp Info VName)
-> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Name
nameFromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ TypeBase () Uniqueness -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine TypeBase () Uniqueness
t') TypeExp Info VName -> Name
typeExpOpaqueName (Maybe (TypeExp Info VName) -> Name)
-> Maybe (TypeExp Info VName) -> Name
forall a b. (a -> b) -> a -> b
$
        EntryType -> Maybe (TypeExp Info VName)
E.entryAscribed EntryType
t
    t' :: TypeBase () Uniqueness
t' = StructType -> TypeBase () NoUniqueness
forall as. TypeBase Size as -> TypeBase () as
E.noSizes (EntryType -> StructType
E.entryType EntryType
t) TypeBase () NoUniqueness -> Uniqueness -> TypeBase () Uniqueness
forall dim u1 u2. TypeBase dim u1 -> u2 -> TypeBase dim u2
`E.setUniqueness` Uniqueness
Nonunique

entryPoint ::
  VisibleTypes ->
  Name ->
  [(E.EntryParam, [I.Param I.DeclType])] ->
  ( E.EntryType,
    [[I.TypeBase I.Rank I.Uniqueness]]
  ) ->
  (I.EntryPoint, I.OpaqueTypes)
entryPoint :: VisibleTypes
-> Name
-> [(EntryParam, [Param DeclType])]
-> (EntryType, [[TypeBase Rank Uniqueness]])
-> (EntryPoint, OpaqueTypes)
entryPoint VisibleTypes
types Name
name [(EntryParam, [Param DeclType])]
params (EntryType
eret, [[TypeBase Rank Uniqueness]]
crets) =
  GenOpaque EntryPoint -> (EntryPoint, OpaqueTypes)
forall a. GenOpaque a -> (a, OpaqueTypes)
runGenOpaque (GenOpaque EntryPoint -> (EntryPoint, OpaqueTypes))
-> GenOpaque EntryPoint -> (EntryPoint, OpaqueTypes)
forall a b. (a -> b) -> a -> b
$
    (Name
name,,)
      ([EntryParam] -> [EntryResult] -> EntryPoint)
-> StateT OpaqueTypes Identity [EntryParam]
-> StateT OpaqueTypes Identity ([EntryResult] -> EntryPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((EntryParam, [Param DeclType])
 -> StateT OpaqueTypes Identity EntryParam)
-> [(EntryParam, [Param DeclType])]
-> StateT OpaqueTypes Identity [EntryParam]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (EntryParam, [Param DeclType])
-> StateT OpaqueTypes Identity EntryParam
forall {dec}.
DeclTyped dec =>
(EntryParam, [Param dec]) -> StateT OpaqueTypes Identity EntryParam
onParam [(EntryParam, [Param DeclType])]
params
      StateT OpaqueTypes Identity ([EntryResult] -> EntryPoint)
-> StateT OpaqueTypes Identity [EntryResult]
-> GenOpaque EntryPoint
forall a b.
StateT OpaqueTypes Identity (a -> b)
-> StateT OpaqueTypes Identity a -> StateT OpaqueTypes Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( ((Uniqueness, EntryPointType) -> EntryResult)
-> [(Uniqueness, EntryPointType)] -> [EntryResult]
forall a b. (a -> b) -> [a] -> [b]
map ((Uniqueness -> EntryPointType -> EntryResult)
-> (Uniqueness, EntryPointType) -> EntryResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Uniqueness -> EntryPointType -> EntryResult
I.EntryResult)
              ([(Uniqueness, EntryPointType)] -> [EntryResult])
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
-> StateT OpaqueTypes Identity [EntryResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ( StructType -> Maybe [StructType]
forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
E.isTupleRecord (StructType -> Maybe [StructType])
-> StructType -> Maybe [StructType]
forall a b. (a -> b) -> a -> b
$ EntryType -> StructType
E.entryType EntryType
eret,
                         EntryType -> Maybe (TypeExp Info VName)
E.entryAscribed EntryType
eret
                       ) of
                (Just [StructType]
ts, Just (E.TETuple [TypeExp Info VName]
e_ts SrcLoc
_)) ->
                  (EntryType
 -> [TypeBase Rank Uniqueness]
 -> StateT OpaqueTypes Identity (Uniqueness, EntryPointType))
-> [EntryType]
-> [[TypeBase Rank Uniqueness]]
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types) ((StructType -> Maybe (TypeExp Info VName) -> EntryType)
-> [StructType] -> [Maybe (TypeExp Info VName)] -> [EntryType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith StructType -> Maybe (TypeExp Info VName) -> EntryType
E.EntryType [StructType]
ts ((TypeExp Info VName -> Maybe (TypeExp Info VName))
-> [TypeExp Info VName] -> [Maybe (TypeExp Info VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp Info VName -> Maybe (TypeExp Info VName)
forall a. a -> Maybe a
Just [TypeExp Info VName]
e_ts)) [[TypeBase Rank Uniqueness]]
crets
                (Just [StructType]
ts, Maybe (TypeExp Info VName)
Nothing) ->
                  (EntryType
 -> [TypeBase Rank Uniqueness]
 -> StateT OpaqueTypes Identity (Uniqueness, EntryPointType))
-> [EntryType]
-> [[TypeBase Rank Uniqueness]]
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types) ((StructType -> EntryType) -> [StructType] -> [EntryType]
forall a b. (a -> b) -> [a] -> [b]
map (StructType -> Maybe (TypeExp Info VName) -> EntryType
`E.EntryType` Maybe (TypeExp Info VName)
forall a. Maybe a
Nothing) [StructType]
ts) [[TypeBase Rank Uniqueness]]
crets
                (Maybe [StructType], Maybe (TypeExp Info VName))
_ ->
                  (Uniqueness, EntryPointType) -> [(Uniqueness, EntryPointType)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Uniqueness, EntryPointType) -> [(Uniqueness, EntryPointType)])
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity [(Uniqueness, EntryPointType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types EntryType
eret ([[TypeBase Rank Uniqueness]] -> [TypeBase Rank Uniqueness]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TypeBase Rank Uniqueness]]
crets)
          )
  where
    onParam :: (EntryParam, [Param dec]) -> StateT OpaqueTypes Identity EntryParam
onParam (E.EntryParam Name
e_p EntryType
e_t, [Param dec]
ps) =
      (Uniqueness -> EntryPointType -> EntryParam)
-> (Uniqueness, EntryPointType) -> EntryParam
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Name -> Uniqueness -> EntryPointType -> EntryParam
I.EntryParam Name
e_p)
        ((Uniqueness, EntryPointType) -> EntryParam)
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
-> StateT OpaqueTypes Identity EntryParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VisibleTypes
-> EntryType
-> [TypeBase Rank Uniqueness]
-> StateT OpaqueTypes Identity (Uniqueness, EntryPointType)
entryPointType VisibleTypes
types EntryType
e_t ((Param dec -> TypeBase Rank Uniqueness)
-> [Param dec] -> [TypeBase Rank Uniqueness]
forall a b. (a -> b) -> [a] -> [b]
map (DeclType -> TypeBase Rank Uniqueness
forall shape u.
ArrayShape shape =>
TypeBase shape u -> TypeBase Rank u
I.rankShaped (DeclType -> TypeBase Rank Uniqueness)
-> (Param dec -> DeclType) -> Param dec -> TypeBase Rank Uniqueness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param dec -> DeclType
forall dec. DeclTyped dec => Param dec -> DeclType
I.paramDeclType) [Param dec]
ps)