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

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

import Control.Monad.State
import Data.List (find)
import qualified Data.Map as M
import Data.String (fromString)
import qualified Futhark.IR as I
import Futhark.Internalise.TypesValues (internalisedTypeSize)
import Futhark.Util.Pretty (prettyOneLine)
import qualified Language.Futhark as E hiding (TypeArg)
import Language.Futhark.Core (Name, Uniqueness (..), VName)
import qualified Language.Futhark.Semantic 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
. ((String, FileModule) -> [TypeBind]) -> Imports -> [TypeBind]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (FileModule -> [TypeBind]
modTypes (FileModule -> [TypeBind])
-> ((String, FileModule) -> FileModule)
-> (String, FileModule)
-> [TypeBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, 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 (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 VName)
findType :: VName -> VisibleTypes -> Maybe (TypeExp VName)
findType VName
v (VisibleTypes [TypeBind]
ts) = TypeBind -> TypeExp VName
forall (f :: * -> *) vn. TypeBindBase f vn -> TypeExp vn
E.typeExp (TypeBind -> TypeExp VName)
-> Maybe TypeBind -> Maybe (TypeExp 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 {} = String -> ValueType
forall a. HasCallStack => String -> a
error String
"valueType Acc"
valueType I.Mem {} = String -> ValueType
forall a. HasCallStack => String -> a
error String
"valueType Mem"

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

rootType :: E.TypeExp VName -> E.TypeExp VName
rootType :: TypeExp VName -> TypeExp VName
rootType (E.TEApply TypeExp VName
te E.TypeArgExpDim {} SrcLoc
_) = TypeExp VName -> TypeExp VName
rootType TypeExp VName
te
rootType (E.TEUnique TypeExp VName
te SrcLoc
_) = TypeExp VName -> TypeExp VName
rootType TypeExp VName
te
rootType TypeExp VName
te = TypeExp VName
te

typeExpOpaqueName :: E.TypeExp VName -> String
typeExpOpaqueName :: TypeExp VName -> String
typeExpOpaqueName = TypeExp VName -> String
f (TypeExp VName -> String)
-> (TypeExp VName -> TypeExp VName) -> TypeExp VName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeExp VName -> TypeExp VName
rootType
  where
    f :: TypeExp VName -> String
f (E.TEArray SizeExp VName
_ TypeExp VName
te SrcLoc
_) =
      let (Int
d, TypeExp VName
te') = TypeExp VName -> (Int, TypeExp VName)
withoutDims TypeExp VName
te
       in String
"arr_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeExp VName -> String
typeExpOpaqueName TypeExp VName
te' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"d"
    f TypeExp VName
te = String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ TypeExp VName -> String
forall a. Pretty a => a -> String
prettyOneLine TypeExp VName
te

type GenOpaque = State I.OpaqueTypes

runGenOpaque :: GenOpaque a -> (a, I.OpaqueTypes)
runGenOpaque :: 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 :: String -> I.OpaqueType -> GenOpaque ()
addType :: String -> OpaqueType -> GenOpaque ()
addType String
s OpaqueType
t = (OpaqueTypes -> OpaqueTypes) -> GenOpaque ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OpaqueTypes -> OpaqueTypes -> OpaqueTypes
forall a. Semigroup a => a -> a -> a
<> [(String, OpaqueType)] -> OpaqueTypes
I.OpaqueTypes [(String
s, OpaqueType
t)])

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

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

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 (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 ()
_ Uniqueness
_ 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 (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 (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 ()
_ Uniqueness
_ 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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null Map Name StructType
fs ->
              let fs' :: [(Name, EntryType)]
fs' = VisibleTypes
-> Map Name StructType
-> Maybe (TypeExp VName)
-> [(Name, EntryType)]
recordFields VisibleTypes
types Map Name StructType
fs (Maybe (TypeExp VName) -> [(Name, EntryType)])
-> Maybe (TypeExp VName) -> [(Name, EntryType)]
forall a b. (a -> b) -> a -> b
$ EntryType -> Maybe (TypeExp VName)
E.entryAscribed EntryType
t
               in String -> OpaqueType -> GenOpaque ()
addType String
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
        StructType
_ -> String -> OpaqueType -> GenOpaque ()
addType String
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Uniqueness
u, String -> EntryPointType
I.TypeOpaque String
desc)
  where
    u :: Uniqueness
u = (Uniqueness -> Uniqueness -> Uniqueness)
-> Uniqueness -> [Uniqueness] -> Uniqueness
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 :: String
desc =
      String
-> (TypeExp VName -> String) -> Maybe (TypeExp VName) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ TypeBase () () -> String
forall a. Pretty a => a -> String
prettyOneLine TypeBase () ()
t') TypeExp VName -> String
typeExpOpaqueName (Maybe (TypeExp VName) -> String)
-> Maybe (TypeExp VName) -> String
forall a b. (a -> b) -> a -> b
$
        EntryType -> Maybe (TypeExp VName)
E.entryAscribed EntryType
t
    t' :: TypeBase () ()
t' = StructType -> TypeBase () ()
forall as. TypeBase Size as -> TypeBase () as
E.noSizes (EntryType -> StructType
E.entryType EntryType
t) TypeBase () () -> Uniqueness -> TypeBase () ()
forall dim as. TypeBase dim as -> Uniqueness -> TypeBase dim as
`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)
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 (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 VName)
E.entryAscribed EntryType
eret
                       ) of
                (Just [StructType]
ts, Just (E.TETuple [TypeExp 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 VName) -> EntryType)
-> [StructType] -> [Maybe (TypeExp VName)] -> [EntryType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith StructType -> Maybe (TypeExp VName) -> EntryType
E.EntryType [StructType]
ts ((TypeExp VName -> Maybe (TypeExp VName))
-> [TypeExp VName] -> [Maybe (TypeExp VName)]
forall a b. (a -> b) -> [a] -> [b]
map TypeExp VName -> Maybe (TypeExp VName)
forall a. a -> Maybe a
Just [TypeExp VName]
e_ts)) [[TypeBase Rank Uniqueness]]
crets
                (Just [StructType]
ts, Maybe (TypeExp 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 VName) -> EntryType
`E.EntryType` Maybe (TypeExp VName)
forall a. Maybe a
Nothing) [StructType]
ts) [[TypeBase Rank Uniqueness]]
crets
                (Maybe [StructType], Maybe (TypeExp VName))
_ ->
                  (Uniqueness, EntryPointType) -> [(Uniqueness, EntryPointType)]
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)