{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module TREXIO.Internal.TH where

import Control.Monad
import Data.Aeson hiding (Success, withArray)
import Data.Bit.ThreadSafe (Bit)
import Data.Bit.ThreadSafe qualified as BV
import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BS
import Data.Char
import Data.Coerce
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Massiv.Array as Massiv hiding (Dim, forM, forM_, mapM, product, replicate, toList, zip)
import Data.Massiv.Array qualified as Massiv
import Data.Massiv.Array.Manifest.Vector qualified as Massiv
import Data.Massiv.Array.Unsafe (unsafeWithPtr)
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as V
import Foreign hiding (peekArray, withArray)
import Foreign qualified as F
import Foreign.C.ConstPtr
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr.Unsafe
import GHC.Generics (Generic)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift (..))
import TREXIO.CooArray
import TREXIO.Internal.Base
import TREXIO.Internal.Marshaller
import Text.Casing
import Text.Read (readMaybe)

tshow :: (Show a) => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

--------------------------------------------------------------------------------

{- | The overall data structure TREXIO uses to represent a wave function as a
JSON specification. A TREXIO scheme consists of multiple data groups and each
data group has multiple fields. A field may require knowledge of other fields.
-}
newtype TrexioScheme = TrexioScheme (Map GroupName Group)
  deriving ((forall x. TrexioScheme -> Rep TrexioScheme x)
-> (forall x. Rep TrexioScheme x -> TrexioScheme)
-> Generic TrexioScheme
forall x. Rep TrexioScheme x -> TrexioScheme
forall x. TrexioScheme -> Rep TrexioScheme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TrexioScheme -> Rep TrexioScheme x
from :: forall x. TrexioScheme -> Rep TrexioScheme x
$cto :: forall x. Rep TrexioScheme x -> TrexioScheme
to :: forall x. Rep TrexioScheme x -> TrexioScheme
Generic, Int -> TrexioScheme -> ShowS
[TrexioScheme] -> ShowS
TrexioScheme -> String
(Int -> TrexioScheme -> ShowS)
-> (TrexioScheme -> String)
-> ([TrexioScheme] -> ShowS)
-> Show TrexioScheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TrexioScheme -> ShowS
showsPrec :: Int -> TrexioScheme -> ShowS
$cshow :: TrexioScheme -> String
show :: TrexioScheme -> String
$cshowList :: [TrexioScheme] -> ShowS
showList :: [TrexioScheme] -> ShowS
Show, TrexioScheme -> TrexioScheme -> Bool
(TrexioScheme -> TrexioScheme -> Bool)
-> (TrexioScheme -> TrexioScheme -> Bool) -> Eq TrexioScheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TrexioScheme -> TrexioScheme -> Bool
== :: TrexioScheme -> TrexioScheme -> Bool
$c/= :: TrexioScheme -> TrexioScheme -> Bool
/= :: TrexioScheme -> TrexioScheme -> Bool
Eq, Eq TrexioScheme
Eq TrexioScheme =>
(TrexioScheme -> TrexioScheme -> Ordering)
-> (TrexioScheme -> TrexioScheme -> Bool)
-> (TrexioScheme -> TrexioScheme -> Bool)
-> (TrexioScheme -> TrexioScheme -> Bool)
-> (TrexioScheme -> TrexioScheme -> Bool)
-> (TrexioScheme -> TrexioScheme -> TrexioScheme)
-> (TrexioScheme -> TrexioScheme -> TrexioScheme)
-> Ord TrexioScheme
TrexioScheme -> TrexioScheme -> Bool
TrexioScheme -> TrexioScheme -> Ordering
TrexioScheme -> TrexioScheme -> TrexioScheme
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TrexioScheme -> TrexioScheme -> Ordering
compare :: TrexioScheme -> TrexioScheme -> Ordering
$c< :: TrexioScheme -> TrexioScheme -> Bool
< :: TrexioScheme -> TrexioScheme -> Bool
$c<= :: TrexioScheme -> TrexioScheme -> Bool
<= :: TrexioScheme -> TrexioScheme -> Bool
$c> :: TrexioScheme -> TrexioScheme -> Bool
> :: TrexioScheme -> TrexioScheme -> Bool
$c>= :: TrexioScheme -> TrexioScheme -> Bool
>= :: TrexioScheme -> TrexioScheme -> Bool
$cmax :: TrexioScheme -> TrexioScheme -> TrexioScheme
max :: TrexioScheme -> TrexioScheme -> TrexioScheme
$cmin :: TrexioScheme -> TrexioScheme -> TrexioScheme
min :: TrexioScheme -> TrexioScheme -> TrexioScheme
Ord, (forall (m :: * -> *). Quote m => TrexioScheme -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    TrexioScheme -> Code m TrexioScheme)
-> Lift TrexioScheme
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TrexioScheme -> m Exp
forall (m :: * -> *).
Quote m =>
TrexioScheme -> Code m TrexioScheme
$clift :: forall (m :: * -> *). Quote m => TrexioScheme -> m Exp
lift :: forall (m :: * -> *). Quote m => TrexioScheme -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
TrexioScheme -> Code m TrexioScheme
liftTyped :: forall (m :: * -> *).
Quote m =>
TrexioScheme -> Code m TrexioScheme
Lift)
  deriving ([TrexioScheme] -> Value
[TrexioScheme] -> Encoding
TrexioScheme -> Value
TrexioScheme -> Encoding
(TrexioScheme -> Value)
-> (TrexioScheme -> Encoding)
-> ([TrexioScheme] -> Value)
-> ([TrexioScheme] -> Encoding)
-> ToJSON TrexioScheme
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TrexioScheme -> Value
toJSON :: TrexioScheme -> Value
$ctoEncoding :: TrexioScheme -> Encoding
toEncoding :: TrexioScheme -> Encoding
$ctoJSONList :: [TrexioScheme] -> Value
toJSONList :: [TrexioScheme] -> Value
$ctoEncodingList :: [TrexioScheme] -> Encoding
toEncodingList :: [TrexioScheme] -> Encoding
ToJSON, Value -> Parser [TrexioScheme]
Value -> Parser TrexioScheme
(Value -> Parser TrexioScheme)
-> (Value -> Parser [TrexioScheme]) -> FromJSON TrexioScheme
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser TrexioScheme
parseJSON :: Value -> Parser TrexioScheme
$cparseJSONList :: Value -> Parser [TrexioScheme]
parseJSONList :: Value -> Parser [TrexioScheme]
FromJSON) via Map GroupName Group

{- | The name of a data group, e.g. @ao@ for atomic orbitals, @basis@ for basis
functions, etc.
-}
newtype GroupName = GroupName Text
  deriving ((forall x. GroupName -> Rep GroupName x)
-> (forall x. Rep GroupName x -> GroupName) -> Generic GroupName
forall x. Rep GroupName x -> GroupName
forall x. GroupName -> Rep GroupName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GroupName -> Rep GroupName x
from :: forall x. GroupName -> Rep GroupName x
$cto :: forall x. Rep GroupName x -> GroupName
to :: forall x. Rep GroupName x -> GroupName
Generic, Int -> GroupName -> ShowS
[GroupName] -> ShowS
GroupName -> String
(Int -> GroupName -> ShowS)
-> (GroupName -> String)
-> ([GroupName] -> ShowS)
-> Show GroupName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GroupName -> ShowS
showsPrec :: Int -> GroupName -> ShowS
$cshow :: GroupName -> String
show :: GroupName -> String
$cshowList :: [GroupName] -> ShowS
showList :: [GroupName] -> ShowS
Show, GroupName -> GroupName -> Bool
(GroupName -> GroupName -> Bool)
-> (GroupName -> GroupName -> Bool) -> Eq GroupName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GroupName -> GroupName -> Bool
== :: GroupName -> GroupName -> Bool
$c/= :: GroupName -> GroupName -> Bool
/= :: GroupName -> GroupName -> Bool
Eq, Eq GroupName
Eq GroupName =>
(GroupName -> GroupName -> Ordering)
-> (GroupName -> GroupName -> Bool)
-> (GroupName -> GroupName -> Bool)
-> (GroupName -> GroupName -> Bool)
-> (GroupName -> GroupName -> Bool)
-> (GroupName -> GroupName -> GroupName)
-> (GroupName -> GroupName -> GroupName)
-> Ord GroupName
GroupName -> GroupName -> Bool
GroupName -> GroupName -> Ordering
GroupName -> GroupName -> GroupName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GroupName -> GroupName -> Ordering
compare :: GroupName -> GroupName -> Ordering
$c< :: GroupName -> GroupName -> Bool
< :: GroupName -> GroupName -> Bool
$c<= :: GroupName -> GroupName -> Bool
<= :: GroupName -> GroupName -> Bool
$c> :: GroupName -> GroupName -> Bool
> :: GroupName -> GroupName -> Bool
$c>= :: GroupName -> GroupName -> Bool
>= :: GroupName -> GroupName -> Bool
$cmax :: GroupName -> GroupName -> GroupName
max :: GroupName -> GroupName -> GroupName
$cmin :: GroupName -> GroupName -> GroupName
min :: GroupName -> GroupName -> GroupName
Ord, (forall (m :: * -> *). Quote m => GroupName -> m Exp)
-> (forall (m :: * -> *). Quote m => GroupName -> Code m GroupName)
-> Lift GroupName
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => GroupName -> m Exp
forall (m :: * -> *). Quote m => GroupName -> Code m GroupName
$clift :: forall (m :: * -> *). Quote m => GroupName -> m Exp
lift :: forall (m :: * -> *). Quote m => GroupName -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => GroupName -> Code m GroupName
liftTyped :: forall (m :: * -> *). Quote m => GroupName -> Code m GroupName
Lift)
  deriving (ToJSONKeyFunction [GroupName]
ToJSONKeyFunction GroupName
ToJSONKeyFunction GroupName
-> ToJSONKeyFunction [GroupName] -> ToJSONKey GroupName
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction GroupName
toJSONKey :: ToJSONKeyFunction GroupName
$ctoJSONKeyList :: ToJSONKeyFunction [GroupName]
toJSONKeyList :: ToJSONKeyFunction [GroupName]
ToJSONKey, FromJSONKeyFunction [GroupName]
FromJSONKeyFunction GroupName
FromJSONKeyFunction GroupName
-> FromJSONKeyFunction [GroupName] -> FromJSONKey GroupName
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction GroupName
fromJSONKey :: FromJSONKeyFunction GroupName
$cfromJSONKeyList :: FromJSONKeyFunction [GroupName]
fromJSONKeyList :: FromJSONKeyFunction [GroupName]
FromJSONKey) via Text

{- | A data group is a record like data structure with named fields of different
types. Each field may or may not be set, thus the 'Maybe' type.
-}
newtype Group = Group (Map DataName Typ)
  deriving ((forall x. Group -> Rep Group x)
-> (forall x. Rep Group x -> Group) -> Generic Group
forall x. Rep Group x -> Group
forall x. Group -> Rep Group x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Group -> Rep Group x
from :: forall x. Group -> Rep Group x
$cto :: forall x. Rep Group x -> Group
to :: forall x. Rep Group x -> Group
Generic, Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
(Int -> Group -> ShowS)
-> (Group -> String) -> ([Group] -> ShowS) -> Show Group
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Group -> ShowS
showsPrec :: Int -> Group -> ShowS
$cshow :: Group -> String
show :: Group -> String
$cshowList :: [Group] -> ShowS
showList :: [Group] -> ShowS
Show, Group -> Group -> Bool
(Group -> Group -> Bool) -> (Group -> Group -> Bool) -> Eq Group
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Group -> Group -> Bool
== :: Group -> Group -> Bool
$c/= :: Group -> Group -> Bool
/= :: Group -> Group -> Bool
Eq, Eq Group
Eq Group =>
(Group -> Group -> Ordering)
-> (Group -> Group -> Bool)
-> (Group -> Group -> Bool)
-> (Group -> Group -> Bool)
-> (Group -> Group -> Bool)
-> (Group -> Group -> Group)
-> (Group -> Group -> Group)
-> Ord Group
Group -> Group -> Bool
Group -> Group -> Ordering
Group -> Group -> Group
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Group -> Group -> Ordering
compare :: Group -> Group -> Ordering
$c< :: Group -> Group -> Bool
< :: Group -> Group -> Bool
$c<= :: Group -> Group -> Bool
<= :: Group -> Group -> Bool
$c> :: Group -> Group -> Bool
> :: Group -> Group -> Bool
$c>= :: Group -> Group -> Bool
>= :: Group -> Group -> Bool
$cmax :: Group -> Group -> Group
max :: Group -> Group -> Group
$cmin :: Group -> Group -> Group
min :: Group -> Group -> Group
Ord, (forall (m :: * -> *). Quote m => Group -> m Exp)
-> (forall (m :: * -> *). Quote m => Group -> Code m Group)
-> Lift Group
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Group -> m Exp
forall (m :: * -> *). Quote m => Group -> Code m Group
$clift :: forall (m :: * -> *). Quote m => Group -> m Exp
lift :: forall (m :: * -> *). Quote m => Group -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Group -> Code m Group
liftTyped :: forall (m :: * -> *). Quote m => Group -> Code m Group
Lift)
  deriving ([Group] -> Value
[Group] -> Encoding
Group -> Value
Group -> Encoding
(Group -> Value)
-> (Group -> Encoding)
-> ([Group] -> Value)
-> ([Group] -> Encoding)
-> ToJSON Group
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Group -> Value
toJSON :: Group -> Value
$ctoEncoding :: Group -> Encoding
toEncoding :: Group -> Encoding
$ctoJSONList :: [Group] -> Value
toJSONList :: [Group] -> Value
$ctoEncodingList :: [Group] -> Encoding
toEncodingList :: [Group] -> Encoding
ToJSON, Value -> Parser [Group]
Value -> Parser Group
(Value -> Parser Group)
-> (Value -> Parser [Group]) -> FromJSON Group
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Group
parseJSON :: Value -> Parser Group
$cparseJSONList :: Value -> Parser [Group]
parseJSONList :: Value -> Parser [Group]
FromJSON) via Map DataName Typ

{- | The name of a data field, as specified by the TREXIO scheme. There is no
guarantee that the name is a valid Haskell identifier. To ensure that, use the
'sanId' function.
-}
newtype DataName = DataName Text
  deriving ((forall x. DataName -> Rep DataName x)
-> (forall x. Rep DataName x -> DataName) -> Generic DataName
forall x. Rep DataName x -> DataName
forall x. DataName -> Rep DataName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DataName -> Rep DataName x
from :: forall x. DataName -> Rep DataName x
$cto :: forall x. Rep DataName x -> DataName
to :: forall x. Rep DataName x -> DataName
Generic, Int -> DataName -> ShowS
[DataName] -> ShowS
DataName -> String
(Int -> DataName -> ShowS)
-> (DataName -> String) -> ([DataName] -> ShowS) -> Show DataName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DataName -> ShowS
showsPrec :: Int -> DataName -> ShowS
$cshow :: DataName -> String
show :: DataName -> String
$cshowList :: [DataName] -> ShowS
showList :: [DataName] -> ShowS
Show, DataName -> DataName -> Bool
(DataName -> DataName -> Bool)
-> (DataName -> DataName -> Bool) -> Eq DataName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DataName -> DataName -> Bool
== :: DataName -> DataName -> Bool
$c/= :: DataName -> DataName -> Bool
/= :: DataName -> DataName -> Bool
Eq, Eq DataName
Eq DataName =>
(DataName -> DataName -> Ordering)
-> (DataName -> DataName -> Bool)
-> (DataName -> DataName -> Bool)
-> (DataName -> DataName -> Bool)
-> (DataName -> DataName -> Bool)
-> (DataName -> DataName -> DataName)
-> (DataName -> DataName -> DataName)
-> Ord DataName
DataName -> DataName -> Bool
DataName -> DataName -> Ordering
DataName -> DataName -> DataName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DataName -> DataName -> Ordering
compare :: DataName -> DataName -> Ordering
$c< :: DataName -> DataName -> Bool
< :: DataName -> DataName -> Bool
$c<= :: DataName -> DataName -> Bool
<= :: DataName -> DataName -> Bool
$c> :: DataName -> DataName -> Bool
> :: DataName -> DataName -> Bool
$c>= :: DataName -> DataName -> Bool
>= :: DataName -> DataName -> Bool
$cmax :: DataName -> DataName -> DataName
max :: DataName -> DataName -> DataName
$cmin :: DataName -> DataName -> DataName
min :: DataName -> DataName -> DataName
Ord, (forall (m :: * -> *). Quote m => DataName -> m Exp)
-> (forall (m :: * -> *). Quote m => DataName -> Code m DataName)
-> Lift DataName
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => DataName -> m Exp
forall (m :: * -> *). Quote m => DataName -> Code m DataName
$clift :: forall (m :: * -> *). Quote m => DataName -> m Exp
lift :: forall (m :: * -> *). Quote m => DataName -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => DataName -> Code m DataName
liftTyped :: forall (m :: * -> *). Quote m => DataName -> Code m DataName
Lift)
  deriving (ToJSONKeyFunction [DataName]
ToJSONKeyFunction DataName
ToJSONKeyFunction DataName
-> ToJSONKeyFunction [DataName] -> ToJSONKey DataName
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction DataName
toJSONKey :: ToJSONKeyFunction DataName
$ctoJSONKeyList :: ToJSONKeyFunction [DataName]
toJSONKeyList :: ToJSONKeyFunction [DataName]
ToJSONKey, FromJSONKeyFunction [DataName]
FromJSONKeyFunction DataName
FromJSONKeyFunction DataName
-> FromJSONKeyFunction [DataName] -> FromJSONKey DataName
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction DataName
fromJSONKey :: FromJSONKeyFunction DataName
$cfromJSONKeyList :: FromJSONKeyFunction [DataName]
fromJSONKeyList :: FromJSONKeyFunction [DataName]
FromJSONKey) via Text

instance ToJSON DataName where
  toJSON :: DataName -> Value
toJSON (DataName Text
name) = Text -> Value
String Text
name

instance FromJSON DataName where
  parseJSON :: Value -> Parser DataName
parseJSON (String Text
name) = DataName -> Parser DataName
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataName -> Parser DataName)
-> (Text -> DataName) -> Text -> Parser DataName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DataName
DataName (Text -> Parser DataName) -> Text -> Parser DataName
forall a b. (a -> b) -> a -> b
$ Text
name
  parseJSON Value
_ = String -> Parser DataName
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseJSON(DataName): could not parse"

{- | The TREXIO type of a data field including sparsity, buffering, dimensionality
etc.
-}
data Typ
  = -- | A 32 integer but meant to represent the size in a given dimension. The
    -- Bool indicates if field can also be written
    Dim Bool Length
  | -- | A 32 bit integer
    Int Length
  | -- | A double precision float. The Bool indicates whether this field is
    -- buffered
    Float Bool Length
  | -- | A string with a given length
    Str Length
  | -- | An index type
    Idx Length
  | -- | Sparse array of floats
    SparseFloat Length
  | -- | A bit field
    BitField Length
  deriving ((forall x. Typ -> Rep Typ x)
-> (forall x. Rep Typ x -> Typ) -> Generic Typ
forall x. Rep Typ x -> Typ
forall x. Typ -> Rep Typ x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Typ -> Rep Typ x
from :: forall x. Typ -> Rep Typ x
$cto :: forall x. Rep Typ x -> Typ
to :: forall x. Rep Typ x -> Typ
Generic, Int -> Typ -> ShowS
[Typ] -> ShowS
Typ -> String
(Int -> Typ -> ShowS)
-> (Typ -> String) -> ([Typ] -> ShowS) -> Show Typ
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Typ -> ShowS
showsPrec :: Int -> Typ -> ShowS
$cshow :: Typ -> String
show :: Typ -> String
$cshowList :: [Typ] -> ShowS
showList :: [Typ] -> ShowS
Show, Typ -> Typ -> Bool
(Typ -> Typ -> Bool) -> (Typ -> Typ -> Bool) -> Eq Typ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Typ -> Typ -> Bool
== :: Typ -> Typ -> Bool
$c/= :: Typ -> Typ -> Bool
/= :: Typ -> Typ -> Bool
Eq, Eq Typ
Eq Typ =>
(Typ -> Typ -> Ordering)
-> (Typ -> Typ -> Bool)
-> (Typ -> Typ -> Bool)
-> (Typ -> Typ -> Bool)
-> (Typ -> Typ -> Bool)
-> (Typ -> Typ -> Typ)
-> (Typ -> Typ -> Typ)
-> Ord Typ
Typ -> Typ -> Bool
Typ -> Typ -> Ordering
Typ -> Typ -> Typ
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Typ -> Typ -> Ordering
compare :: Typ -> Typ -> Ordering
$c< :: Typ -> Typ -> Bool
< :: Typ -> Typ -> Bool
$c<= :: Typ -> Typ -> Bool
<= :: Typ -> Typ -> Bool
$c> :: Typ -> Typ -> Bool
> :: Typ -> Typ -> Bool
$c>= :: Typ -> Typ -> Bool
>= :: Typ -> Typ -> Bool
$cmax :: Typ -> Typ -> Typ
max :: Typ -> Typ -> Typ
$cmin :: Typ -> Typ -> Typ
min :: Typ -> Typ -> Typ
Ord, (forall (m :: * -> *). Quote m => Typ -> m Exp)
-> (forall (m :: * -> *). Quote m => Typ -> Code m Typ) -> Lift Typ
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Typ -> m Exp
forall (m :: * -> *). Quote m => Typ -> Code m Typ
$clift :: forall (m :: * -> *). Quote m => Typ -> m Exp
lift :: forall (m :: * -> *). Quote m => Typ -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Typ -> Code m Typ
liftTyped :: forall (m :: * -> *). Quote m => Typ -> Code m Typ
Lift)

instance ToJSON Typ where
  toJSON :: Typ -> Value
toJSON (Dim Bool
False Length
len) = Array -> Value
Array [Value
Item Array
"dim", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Dim Bool
True Length
len) = Array -> Value
Array [Value
Item Array
"dim readonly", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Int Length
len) = Array -> Value
Array [Value
Item Array
"int", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Float Bool
False Length
len) = Array -> Value
Array [Value
Item Array
"float", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Float Bool
True Length
len) = Array -> Value
Array [Value
Item Array
"float buffered", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Str Length
len) = Array -> Value
Array [Value
Item Array
"str", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (Idx Length
len) = Array -> Value
Array [Value
Item Array
"index", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (SparseFloat Length
len) = Array -> Value
Array [Value
Item Array
"float sparse", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]
  toJSON (BitField Length
len) = Array -> Value
Array [Value
Item Array
"int special", Length -> Value
forall a. ToJSON a => a -> Value
toJSON Length
len]

instance FromJSON Typ where
  parseJSON :: Value -> Parser Typ
parseJSON (Array [Item Array
"dim", Item Array
len]) = Bool -> Length -> Typ
Dim Bool
True (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"dim readonly", Item Array
len]) = Bool -> Length -> Typ
Dim Bool
False (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"int", Item Array
len]) = Length -> Typ
Int (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"float", Item Array
len]) = Bool -> Length -> Typ
Float Bool
False (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"float buffered", Item Array
len]) = Bool -> Length -> Typ
Float Bool
True (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"str", Item Array
len]) = Length -> Typ
Str (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"index", Item Array
len]) = Length -> Typ
Idx (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"float sparse", Item Array
len]) = Length -> Typ
SparseFloat (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON (Array [Item Array
"int special", Item Array
len]) = Length -> Typ
BitField (Length -> Typ) -> Parser Length -> Parser Typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Length
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item Array
len
  parseJSON Value
_ = String -> Parser Typ
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseJSON(Typ): could not parse"

{- | TREXIO data fields are annotated with a length specification. This
specification is a list of sizes along the dimensions of an $n$D array.
An empty length specification refers to a scalar. A dimension may have a
constant size or refer to another field that stores its size, see 'DimLength'.
-}
newtype Length = Length [DimLength] deriving ((forall x. Length -> Rep Length x)
-> (forall x. Rep Length x -> Length) -> Generic Length
forall x. Rep Length x -> Length
forall x. Length -> Rep Length x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Length -> Rep Length x
from :: forall x. Length -> Rep Length x
$cto :: forall x. Rep Length x -> Length
to :: forall x. Rep Length x -> Length
Generic, Int -> Length -> ShowS
[Length] -> ShowS
Length -> String
(Int -> Length -> ShowS)
-> (Length -> String) -> ([Length] -> ShowS) -> Show Length
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Length -> ShowS
showsPrec :: Int -> Length -> ShowS
$cshow :: Length -> String
show :: Length -> String
$cshowList :: [Length] -> ShowS
showList :: [Length] -> ShowS
Show, Length -> Length -> Bool
(Length -> Length -> Bool)
-> (Length -> Length -> Bool) -> Eq Length
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Length -> Length -> Bool
== :: Length -> Length -> Bool
$c/= :: Length -> Length -> Bool
/= :: Length -> Length -> Bool
Eq, Eq Length
Eq Length =>
(Length -> Length -> Ordering)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Length)
-> (Length -> Length -> Length)
-> Ord Length
Length -> Length -> Bool
Length -> Length -> Ordering
Length -> Length -> Length
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Length -> Length -> Ordering
compare :: Length -> Length -> Ordering
$c< :: Length -> Length -> Bool
< :: Length -> Length -> Bool
$c<= :: Length -> Length -> Bool
<= :: Length -> Length -> Bool
$c> :: Length -> Length -> Bool
> :: Length -> Length -> Bool
$c>= :: Length -> Length -> Bool
>= :: Length -> Length -> Bool
$cmax :: Length -> Length -> Length
max :: Length -> Length -> Length
$cmin :: Length -> Length -> Length
min :: Length -> Length -> Length
Ord, (forall (m :: * -> *). Quote m => Length -> m Exp)
-> (forall (m :: * -> *). Quote m => Length -> Code m Length)
-> Lift Length
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Length -> m Exp
forall (m :: * -> *). Quote m => Length -> Code m Length
$clift :: forall (m :: * -> *). Quote m => Length -> m Exp
lift :: forall (m :: * -> *). Quote m => Length -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Length -> Code m Length
liftTyped :: forall (m :: * -> *). Quote m => Length -> Code m Length
Lift)

instance ToJSON Length where
  toJSON :: Length -> Value
toJSON (Length [DimLength]
dim) = Array -> Value
Array (Array -> Value) -> ([DimLength] -> Array) -> [DimLength] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array)
-> ([DimLength] -> [Value]) -> [DimLength] -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DimLength -> Value) -> [DimLength] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DimLength -> Value
forall a. ToJSON a => a -> Value
toJSON ([DimLength] -> Value) -> [DimLength] -> Value
forall a b. (a -> b) -> a -> b
$ [DimLength]
dim

instance FromJSON Length where
  parseJSON :: Value -> Parser Length
parseJSON (Array Array
arr) =
    [DimLength] -> Length
Length ([DimLength] -> Length)
-> (Vector DimLength -> [DimLength]) -> Vector DimLength -> Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector DimLength -> [DimLength]
forall a. Vector a -> [a]
V.toList
      (Vector DimLength -> Length)
-> Parser (Vector DimLength) -> Parser Length
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser DimLength) -> Array -> Parser (Vector DimLength)
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) -> Vector a -> f (Vector b)
traverse (forall a. FromJSON a => Value -> Parser a
parseJSON @DimLength) Array
arr
  parseJSON Value
_ = String -> Parser Length
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseJSON(Length): could not parse"

{- | The size along a dimension of a field. It can be a constant or refer to
a field that stores a scalar describing a length.
-}
data DimLength
  = Const Int
  | Field GroupName DataName
  deriving ((forall x. DimLength -> Rep DimLength x)
-> (forall x. Rep DimLength x -> DimLength) -> Generic DimLength
forall x. Rep DimLength x -> DimLength
forall x. DimLength -> Rep DimLength x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DimLength -> Rep DimLength x
from :: forall x. DimLength -> Rep DimLength x
$cto :: forall x. Rep DimLength x -> DimLength
to :: forall x. Rep DimLength x -> DimLength
Generic, Int -> DimLength -> ShowS
[DimLength] -> ShowS
DimLength -> String
(Int -> DimLength -> ShowS)
-> (DimLength -> String)
-> ([DimLength] -> ShowS)
-> Show DimLength
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DimLength -> ShowS
showsPrec :: Int -> DimLength -> ShowS
$cshow :: DimLength -> String
show :: DimLength -> String
$cshowList :: [DimLength] -> ShowS
showList :: [DimLength] -> ShowS
Show, DimLength -> DimLength -> Bool
(DimLength -> DimLength -> Bool)
-> (DimLength -> DimLength -> Bool) -> Eq DimLength
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DimLength -> DimLength -> Bool
== :: DimLength -> DimLength -> Bool
$c/= :: DimLength -> DimLength -> Bool
/= :: DimLength -> DimLength -> Bool
Eq, Eq DimLength
Eq DimLength =>
(DimLength -> DimLength -> Ordering)
-> (DimLength -> DimLength -> Bool)
-> (DimLength -> DimLength -> Bool)
-> (DimLength -> DimLength -> Bool)
-> (DimLength -> DimLength -> Bool)
-> (DimLength -> DimLength -> DimLength)
-> (DimLength -> DimLength -> DimLength)
-> Ord DimLength
DimLength -> DimLength -> Bool
DimLength -> DimLength -> Ordering
DimLength -> DimLength -> DimLength
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DimLength -> DimLength -> Ordering
compare :: DimLength -> DimLength -> Ordering
$c< :: DimLength -> DimLength -> Bool
< :: DimLength -> DimLength -> Bool
$c<= :: DimLength -> DimLength -> Bool
<= :: DimLength -> DimLength -> Bool
$c> :: DimLength -> DimLength -> Bool
> :: DimLength -> DimLength -> Bool
$c>= :: DimLength -> DimLength -> Bool
>= :: DimLength -> DimLength -> Bool
$cmax :: DimLength -> DimLength -> DimLength
max :: DimLength -> DimLength -> DimLength
$cmin :: DimLength -> DimLength -> DimLength
min :: DimLength -> DimLength -> DimLength
Ord, (forall (m :: * -> *). Quote m => DimLength -> m Exp)
-> (forall (m :: * -> *). Quote m => DimLength -> Code m DimLength)
-> Lift DimLength
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => DimLength -> m Exp
forall (m :: * -> *). Quote m => DimLength -> Code m DimLength
$clift :: forall (m :: * -> *). Quote m => DimLength -> m Exp
lift :: forall (m :: * -> *). Quote m => DimLength -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => DimLength -> Code m DimLength
liftTyped :: forall (m :: * -> *). Quote m => DimLength -> Code m DimLength
Lift)

instance ToJSON DimLength where
  toJSON :: DimLength -> Value
toJSON (Const Int
int) = Text -> Value
String (Text -> Value) -> (Int -> Text) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int
int
  toJSON (Field (GroupName Text
groupName) (DataName Text
dataName)) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
groupName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dataName

instance FromJSON DimLength where
  parseJSON :: Value -> Parser DimLength
parseJSON (String Text
s) = case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe Int) -> Text -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text
s of
    Just Int
i -> DimLength -> Parser DimLength
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (DimLength -> Parser DimLength)
-> (Int -> DimLength) -> Int -> Parser DimLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DimLength
Const (Int -> Parser DimLength) -> Int -> Parser DimLength
forall a b. (a -> b) -> a -> b
$ Int
i
    Maybe Int
Nothing -> case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
s of
      [Item [Text]
groupName, Item [Text]
dataName] -> DimLength -> Parser DimLength
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (DimLength -> Parser DimLength) -> DimLength -> Parser DimLength
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> DimLength
Field (Text -> GroupName
GroupName Text
Item [Text]
groupName) (Text -> DataName
DataName Text
Item [Text]
dataName)
      [Text]
_ -> String -> Parser DimLength
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseJSON(DimLength): could not parse"
  parseJSON Value
_ = String -> Parser DimLength
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseJSON(DimLength): could not parse"

--------------------------------------------------------------------------------
-- Helper functions

{- | Sanitise an identifier, e.g. a field name or function name. I.e. we ensure
it starts with a valid lower case letter or symbol.
-}
sanId :: String -> String
sanId :: ShowS
sanId String
"" = ShowS
forall a. HasCallStack => String -> a
error String
"sanId: empty string"
sanId ind :: String
ind@(Char
c : String
cs)
  | Char -> Bool
isUpperCase Char
c = ShowS
sanId ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
  | Char -> Bool
isDigit Char
c = ShowS
sanId ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
  | String
ind String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"type" = String
"type'"
  | String
ind String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"class" = String
"class'"
  | Bool
otherwise = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs

--------------------------------------------------------------------------------
-- Template Haskell binding generator

-- | The standard operations on data fields.
data FieldOps
  = -- | Check if a field is set
    Has
  | -- | Read data from a field
    Read
  | -- | Write data to a field
    Write
  deriving ((forall x. FieldOps -> Rep FieldOps x)
-> (forall x. Rep FieldOps x -> FieldOps) -> Generic FieldOps
forall x. Rep FieldOps x -> FieldOps
forall x. FieldOps -> Rep FieldOps x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FieldOps -> Rep FieldOps x
from :: forall x. FieldOps -> Rep FieldOps x
$cto :: forall x. Rep FieldOps x -> FieldOps
to :: forall x. Rep FieldOps x -> FieldOps
Generic, FieldOps -> FieldOps -> Bool
(FieldOps -> FieldOps -> Bool)
-> (FieldOps -> FieldOps -> Bool) -> Eq FieldOps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldOps -> FieldOps -> Bool
== :: FieldOps -> FieldOps -> Bool
$c/= :: FieldOps -> FieldOps -> Bool
/= :: FieldOps -> FieldOps -> Bool
Eq, Int -> FieldOps -> ShowS
[FieldOps] -> ShowS
FieldOps -> String
(Int -> FieldOps -> ShowS)
-> (FieldOps -> String) -> ([FieldOps] -> ShowS) -> Show FieldOps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldOps -> ShowS
showsPrec :: Int -> FieldOps -> ShowS
$cshow :: FieldOps -> String
show :: FieldOps -> String
$cshowList :: [FieldOps] -> ShowS
showList :: [FieldOps] -> ShowS
Show, Eq FieldOps
Eq FieldOps =>
(FieldOps -> FieldOps -> Ordering)
-> (FieldOps -> FieldOps -> Bool)
-> (FieldOps -> FieldOps -> Bool)
-> (FieldOps -> FieldOps -> Bool)
-> (FieldOps -> FieldOps -> Bool)
-> (FieldOps -> FieldOps -> FieldOps)
-> (FieldOps -> FieldOps -> FieldOps)
-> Ord FieldOps
FieldOps -> FieldOps -> Bool
FieldOps -> FieldOps -> Ordering
FieldOps -> FieldOps -> FieldOps
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldOps -> FieldOps -> Ordering
compare :: FieldOps -> FieldOps -> Ordering
$c< :: FieldOps -> FieldOps -> Bool
< :: FieldOps -> FieldOps -> Bool
$c<= :: FieldOps -> FieldOps -> Bool
<= :: FieldOps -> FieldOps -> Bool
$c> :: FieldOps -> FieldOps -> Bool
> :: FieldOps -> FieldOps -> Bool
$c>= :: FieldOps -> FieldOps -> Bool
>= :: FieldOps -> FieldOps -> Bool
$cmax :: FieldOps -> FieldOps -> FieldOps
max :: FieldOps -> FieldOps -> FieldOps
$cmin :: FieldOps -> FieldOps -> FieldOps
min :: FieldOps -> FieldOps -> FieldOps
Ord)

opsFnName :: FieldOps -> String
opsFnName :: FieldOps -> String
opsFnName FieldOps
Has = String
"has"
opsFnName FieldOps
Read = String
"read"
opsFnName FieldOps
Write = String
"write"

-- | Associate a TREXIO 'Typ' with a Haskell 'Type'.
typToType :: (Quote m) => Typ -> m Type
typToType :: forall (m :: * -> *). Quote m => Typ -> m Type
typToType (Dim Bool
_ (Length [])) = [t|Int|]
typToType (Dim Bool
_ (Length [Item [DimLength]
_])) = [t|Vector S Int|]
typToType (Int (Length [])) = [t|Int|]
typToType (Int (Length [Item [DimLength]
_])) = [t|Vector S Int|]
typToType (Float Bool
False (Length [])) = [t|Double|]
typToType (Float Bool
False (Length [Item [DimLength]
_])) = [t|Vector S Double|]
typToType (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|Matrix S Double|]
typToType (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|Massiv.Array S Ix3 Double|]
typToType (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|Massiv.Array S Ix4 Double|]
typToType (Float Bool
True (Length [Item [DimLength]
_])) = [t|Vector S Double|]
typToType (Str (Length [])) = [t|Text|]
typToType (Str (Length [Item [DimLength]
_])) = [t|Vector B Text|]
typToType (Idx (Length [])) = [t|Int|]
typToType (Idx (Length [Item [DimLength]
_])) = [t|Vector S Int|]
typToType (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|CooArray U Ix2 Double|]
typToType (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|CooArray U Ix3 Double|]
typToType (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|CooArray U Ix4 Double|]
typToType (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|CooArray U (IxN 6) Double|]
typToType (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|CooArray U (IxN 8) Double|]
typToType (BitField (Length [Item [DimLength]
_])) = [t|BV.Vector Word8|]
typToType Typ
t = String -> m Type
forall a. HasCallStack => String -> a
error (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$ String
"Can not associate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with a Type"

-- | Associate a 'FieldOps' and a TREXIO field 'Typ' with a Haskell function type.
mkCFnSig :: FieldOps -> Typ -> Q Type
mkCFnSig :: FieldOps -> Typ -> Q Type
mkCFnSig FieldOps
Has Typ
_ = [t|Trexio -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Dim Bool
_ Length
_) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Int Length
_) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Float Bool
False Length
_) = [t|Trexio -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Float Bool
True Length
_) = [t|Trexio -> Int64 -> Ptr Int64 -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Str (Length [])) = [t|Trexio -> Ptr CChar -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Str (Length [Item [DimLength]
_])) = [t|Trexio -> Ptr (Ptr CChar) -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (Idx Length
_) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (SparseFloat Length
_) = [t|Trexio -> Int64 -> Ptr Int64 -> Ptr Int32 -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Read (BitField Length
_) = [t|Trexio -> Int64 -> Ptr Int64 -> Ptr Int64 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Dim Bool
_ (Length [])) = [t|Trexio -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Dim Bool
_ (Length [Item [DimLength]
_])) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Int (Length [])) = [t|Trexio -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Int (Length [Item [DimLength]
_])) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Float Bool
False (Length [])) = [t|Trexio -> CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Float Bool
False (Length [DimLength]
_)) = [t|Trexio -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Float Bool
True (Length [DimLength]
_)) = [t|Trexio -> Int64 -> Int64 -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Str (Length [])) = [t|Trexio -> ConstPtr CChar -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Str (Length [Item [DimLength]
_])) = [t|Trexio -> ConstPtr (ConstPtr CChar) -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Idx (Length [])) = [t|Trexio -> Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (Idx (Length [Item [DimLength]
_])) = [t|Trexio -> Ptr Int32 -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (SparseFloat Length
_) = [t|Trexio -> Int64 -> Int64 -> Ptr Int32 -> Ptr CDouble -> IO ExitCodeC|]
mkCFnSig FieldOps
Write (BitField Length
_) = [t|Trexio -> Int64 -> Int64 -> Ptr Int64 -> IO ExitCodeC|]
mkCFnSig FieldOps
op Typ
t = String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Can not associate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FieldOps -> String
forall a. Show a => a -> String
show FieldOps
op String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with a Type"

{- | Associate a 'FieldOps' and a field 'Typ' with the type of a Haskell function.
The Haskell function is already abstracted and expected to perform other queries
such as vector sizes as necessary.
-}
mkHsFnSig :: FieldOps -> Typ -> Q Type
mkHsFnSig :: FieldOps -> Typ -> Q Type
mkHsFnSig FieldOps
Has Typ
_ = [t|forall m. (MonadIO m) => Trexio -> m Bool|]
mkHsFnSig FieldOps
Read (Dim Bool
_ (Length [])) = [t|forall m. (MonadIO m) => Trexio -> m Int|]
mkHsFnSig FieldOps
Read (Dim Bool
_ (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector S Int)|]
mkHsFnSig FieldOps
Read (Int (Length [])) = [t|forall m. (MonadIO m) => Trexio -> m Int|]
mkHsFnSig FieldOps
Read (Int (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector S Int)|]
mkHsFnSig FieldOps
Read (Float Bool
False (Length [])) = [t|forall m. (MonadIO m) => Trexio -> m Double|]
mkHsFnSig FieldOps
Read (Float Bool
False (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector S Double)|]
mkHsFnSig FieldOps
Read (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Matrix S Double)|]
mkHsFnSig FieldOps
Read (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Massiv.Array S Ix3 Double)|]
mkHsFnSig FieldOps
Read (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Massiv.Array S Ix4 Double)|]
mkHsFnSig FieldOps
Read (Float Bool
True (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector S Double)|]
mkHsFnSig FieldOps
Read (Str (Length [])) = [t|forall m. (MonadIO m) => Trexio -> m Text|]
mkHsFnSig FieldOps
Read (Str (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector B Text)|]
mkHsFnSig FieldOps
Read (Idx (Length [])) = [t|forall m. (MonadIO m) => Trexio -> m Int|]
mkHsFnSig FieldOps
Read (Idx (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Vector S Int)|]
mkHsFnSig FieldOps
Read (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (CooArray U Ix2 Double)|]
mkHsFnSig FieldOps
Read (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (CooArray U Ix3 Double)|]
mkHsFnSig FieldOps
Read (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (CooArray U Ix4 Double)|]
mkHsFnSig FieldOps
Read (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (CooArray U (IxN 6) Double)|]
mkHsFnSig FieldOps
Read (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (CooArray U (IxN 8) Double)|]
mkHsFnSig FieldOps
Read (BitField (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> m (Matrix U (Bit, Bit))|]
mkHsFnSig FieldOps
Write (Dim Bool
_ (Length [])) = [t|forall m. (MonadIO m) => Trexio -> Int -> m ()|]
mkHsFnSig FieldOps
Write (Dim Bool
_ (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector S Int -> m ()|]
mkHsFnSig FieldOps
Write (Int (Length [])) = [t|forall m. (MonadIO m) => Trexio -> Int -> m ()|]
mkHsFnSig FieldOps
Write (Int (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector S Int -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
False (Length [])) = [t|forall m. (MonadIO m) => Trexio -> Double -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
False (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector S Double -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Matrix S Double -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Massiv.Array S Ix3 Double -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
False (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Massiv.Array S Ix4 Double -> m ()|]
mkHsFnSig FieldOps
Write (Float Bool
True (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector S Double -> m ()|]
mkHsFnSig FieldOps
Write (Str (Length [])) = [t|forall m. (MonadIO m) => Trexio -> Text -> m ()|]
mkHsFnSig FieldOps
Write (Str (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector B Text -> m ()|]
mkHsFnSig FieldOps
Write (Idx (Length [])) = [t|forall m. (MonadIO m) => Trexio -> Int -> m ()|]
mkHsFnSig FieldOps
Write (Idx (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Vector S Int -> m ()|]
mkHsFnSig FieldOps
Write (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> CooArray U Ix2 Double -> m ()|]
mkHsFnSig FieldOps
Write (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> CooArray U Ix3 Double -> m ()|]
mkHsFnSig FieldOps
Write (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> CooArray U Ix4 Double -> m ()|]
mkHsFnSig FieldOps
Write (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> CooArray U (IxN 6) Double -> m ()|]
mkHsFnSig FieldOps
Write (SparseFloat (Length [Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_, Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> CooArray U (IxN 8) Double -> m ()|]
mkHsFnSig FieldOps
Write (BitField (Length [Item [DimLength]
_])) = [t|forall m. (MonadIO m) => Trexio -> Matrix U (Bit, Bit) -> m ()|]
mkHsFnSig FieldOps
op Typ
t = String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Can not associate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FieldOps -> String
forall a. Show a => a -> String
show FieldOps
op String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with a Type"

-- | Generate a Haskell function name for a given operation, group and field of that group.
mkHsFnName :: FieldOps -> GroupName -> DataName -> String
mkHsFnName :: FieldOps -> GroupName -> DataName -> String
mkHsFnName FieldOps
op (GroupName Text
groupName) (DataName Text
dataName) =
  ShowS
sanId ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
camel ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FieldOps -> String
opsFnName FieldOps
op String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
groupName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
dataName

-- | Generate a C function name for a given operation, group and field of that group.
mkCFnName :: FieldOps -> GroupName -> DataName -> String
mkCFnName :: FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
op (GroupName Text
groupName) (DataName Text
dataName) =
  String
"trexio_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FieldOps -> String
opsFnName FieldOps
op String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
groupName) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
dataName)

-- | Convert a field to a type
fieldToType :: (Quote m) => DataName -> Typ -> m VarBangType
fieldToType :: forall (m :: * -> *). Quote m => DataName -> Typ -> m VarBangType
fieldToType (DataName Text
dataName) Typ
typ = do
  let fieldName :: Name
fieldName = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanId ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
camel ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
dataName
  Type
fieldType <- Typ -> m Type
forall (m :: * -> *). Quote m => Typ -> m Type
typToType Typ
typ
  Type
maybeFieldType <- [t|Maybe $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
fieldType)|]
  VarBangType -> m VarBangType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fieldName, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
maybeFieldType)

stdDerivs :: [DerivClause]
stdDerivs :: [DerivClause]
stdDerivs = [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Generic, Name -> Type
ConT ''Show, Name -> Type
ConT ''Ord, Name -> Type
ConT ''Eq]]

-- | Create a record from a given data group
mkRecord :: GroupName -> Group -> Q Dec
mkRecord :: GroupName -> Group -> Q Dec
mkRecord (GroupName Text
groupName) (Group Map DataName Typ
fields) = do
  Name
groupNameTD <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Text -> String) -> Text -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
pascal ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Q Name) -> Text -> Q Name
forall a b. (a -> b) -> a -> b
$ Text
groupName
  Name
groupNameTC <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Text -> String) -> Text -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
pascal ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Q Name) -> Text -> Q Name
forall a b. (a -> b) -> a -> b
$ Text
groupName
  [VarBangType]
fieldsT <- ((DataName, Typ) -> Q VarBangType)
-> [(DataName, Typ)] -> Q [VarBangType]
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) -> [a] -> f [b]
traverse ((DataName -> Typ -> Q VarBangType)
-> (DataName, Typ) -> Q VarBangType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DataName -> Typ -> Q VarBangType
forall (m :: * -> *). Quote m => DataName -> Typ -> m VarBangType
fieldToType) ([(DataName, Typ)] -> Q [VarBangType])
-> (Map DataName Typ -> [(DataName, Typ)])
-> Map DataName Typ
-> Q [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map DataName Typ -> [(DataName, Typ)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map DataName Typ -> Q [VarBangType])
-> Map DataName Typ -> Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ Map DataName Typ
fields
  Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
groupNameTD [] Maybe Type
forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
groupNameTC [VarBangType]
fieldsT] [DerivClause]
stdDerivs

-- | Create the TREXIO scheme type with subrecords for each data group.
mkTrexioScheme :: TrexioScheme -> Q Dec
mkTrexioScheme :: TrexioScheme -> Q Dec
mkTrexioScheme (TrexioScheme Map GroupName Group
groups) = do
  Name
dataName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"TREXIO"
  Name
constructorName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"TREXIO"
  [VarBangType]
fieldsT <- [(GroupName, Group)]
-> ((GroupName, Group) -> Q VarBangType) -> Q [VarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map GroupName Group -> [(GroupName, Group)]
forall k a. Map k a -> [(k, a)]
Map.toList Map GroupName Group
groups) (((GroupName, Group) -> Q VarBangType) -> Q [VarBangType])
-> ((GroupName, Group) -> Q VarBangType) -> Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ \(GroupName Text
groupName, Group
_) -> do
    Name
groupFieldName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Text -> String) -> Text -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
camel ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Q Name) -> Text -> Q Name
forall a b. (a -> b) -> a -> b
$ Text
groupName
    Type
groupFieldType <- [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Text -> Name) -> Text -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
pascal ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Q Type) -> Text -> Q Type
forall a b. (a -> b) -> a -> b
$ Text
groupName)|]
    VarBangType -> Q VarBangType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
groupFieldName, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
groupFieldType)
  Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dataName [] Maybe Type
forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
constructorName [VarBangType]
fieldsT] [DerivClause]
stdDerivs

-- | Create all C function bindings for a given group
mkCBindings :: GroupName -> Group -> Q [Dec]
mkCBindings :: GroupName -> Group -> Q [Dec]
mkCBindings GroupName
groupName (Group Map DataName Typ
fields) = do
  -- Group bindings for delete
  Dec
groupDelBind <- GroupName -> Q Dec
mkCDeleteFn GroupName
groupName
  [Dec]
fieldBinds <- ([[Maybe Dec]] -> [Dec]) -> Q [[Maybe Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe Dec] -> [Dec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Dec] -> [Dec])
-> ([[Maybe Dec]] -> [Maybe Dec]) -> [[Maybe Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe Dec]] -> [Maybe Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Q [[Maybe Dec]] -> Q [Dec])
-> (((DataName, Typ) -> Q [Maybe Dec]) -> Q [[Maybe Dec]])
-> ((DataName, Typ) -> Q [Maybe Dec])
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DataName, Typ)]
-> ((DataName, Typ) -> Q [Maybe Dec]) -> Q [[Maybe Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map DataName Typ -> [(DataName, Typ)]
forall k a. Map k a -> [(k, a)]
Map.toList Map DataName Typ
fields) (((DataName, Typ) -> Q [Maybe Dec]) -> Q [Dec])
-> ((DataName, Typ) -> Q [Maybe Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(DataName
fieldName, Typ
fieldTyp) -> do
    -- Standard bindings
    [Maybe Dec]
stdBindings <- [FieldOps] -> (FieldOps -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Item [FieldOps]
FieldOps
Has, Item [FieldOps]
FieldOps
Read, Item [FieldOps]
FieldOps
Write] ((FieldOps -> Q (Maybe Dec)) -> Q [Maybe Dec])
-> (FieldOps -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall a b. (a -> b) -> a -> b
$ \FieldOps
op -> do
      let cFnName :: String
cFnName = FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
op GroupName
groupName DataName
fieldName
      Name
cFnNameT <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
cFnName
      Type
cFnSig <- FieldOps -> Typ -> Q Type
mkCFnSig FieldOps
op Typ
fieldTyp

      -- Dim fields, that are read only, do not have a write function
      if Typ
fieldTyp Typ -> Typ -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Length -> Typ
Dim Bool
False ([DimLength] -> Length
Length []) Bool -> Bool -> Bool
&& FieldOps
op FieldOps -> FieldOps -> Bool
forall a. Eq a => a -> a -> Bool
== FieldOps
Write
        then Maybe Dec -> Q (Maybe Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Dec
forall a. Maybe a
Nothing
        else Maybe Dec -> Q (Maybe Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Dec -> Q (Maybe Dec))
-> (Foreign -> Maybe Dec) -> Foreign -> Q (Maybe Dec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> (Foreign -> Dec) -> Foreign -> Maybe Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Dec
ForeignD (Foreign -> Q (Maybe Dec)) -> Foreign -> Q (Maybe Dec)
forall a b. (a -> b) -> a -> b
$ Callconv -> Safety -> String -> Name -> Type -> Foreign
ImportF Callconv
CApi Safety
Unsafe (String
"trexio.h " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cFnName) Name
cFnNameT Type
cFnSig

    -- "size" bindings: bitfields, sparse arrays and buffered arrays have an
    -- additional function "_size", that tells how many COO elements there are.
    let cSizeFnString :: String
cSizeFnString = GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
fieldName
    Name
cSizeFnName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
cSizeFnString
    Type
cFnSig <- [t|Trexio -> Ptr Int64 -> IO Int32|]
    let imprt :: Dec
imprt =
          Foreign -> Dec
ForeignD (Foreign -> Dec) -> Foreign -> Dec
forall a b. (a -> b) -> a -> b
$
            Callconv -> Safety -> String -> Name -> Type -> Foreign
ImportF Callconv
CApi Safety
Unsafe (String
"trexio.h " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cSizeFnString) Name
cSizeFnName Type
cFnSig
    let sizeBinding :: Maybe Dec
sizeBinding = case Typ
fieldTyp of
          SparseFloat Length
_ -> Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
imprt
          Float Bool
True Length
_ -> Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
imprt
          Typ
_ -> Maybe Dec
forall a. Maybe a
Nothing

    -- Return all bindings
    [Maybe Dec] -> Q [Maybe Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Dec] -> Q [Maybe Dec]) -> [Maybe Dec] -> Q [Maybe Dec]
forall a b. (a -> b) -> a -> b
$ [Maybe Dec]
stdBindings [Maybe Dec] -> [Maybe Dec] -> [Maybe Dec]
forall a. Semigroup a => a -> a -> a
<> [Maybe Dec
Item [Maybe Dec]
sizeBinding]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
groupDelBind Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
fieldBinds

-- Make a Has function for a given field
mkHsHasFn :: GroupName -> DataName -> Typ -> Q [Dec]
mkHsHasFn :: GroupName -> DataName -> Typ -> Q [Dec]
mkHsHasFn GroupName
groupName DataName
dataName Typ
fieldTyp = do
  let hsFnName :: String
hsFnName = FieldOps -> GroupName -> DataName -> String
mkHsFnName FieldOps
Has GroupName
groupName DataName
dataName
      cFnName :: String
cFnName = FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Has GroupName
groupName DataName
dataName
  Type
hsFnSig <- FieldOps -> Typ -> Q Type
mkHsFnSig FieldOps
Has Typ
fieldTyp
  Exp
hsExp <-
    [e|
      \trexio -> liftIO $ do
        cRes <- $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
cFnName) trexio
        if exitCodeH cRes == Success
          then return True
          else return False
      |]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Name -> Type -> Dec
SigD (String -> Name
mkName String
hsFnName) Type
hsFnSig
    , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
hsFnName) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
hsExp) []]
    ]

{- | Generate an expression to obtain the size of an array field along a given
dimension.
-}
mkSizeFn :: DimLength -> Q Exp
mkSizeFn :: DimLength -> Q Exp
mkSizeFn (Const Int
i) = [e|\_ -> return i|]
mkSizeFn (Field GroupName
groupName DataName
dataName) = do
  let cFnName :: String
cFnName = FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName
  [e|
    ( \trexio -> alloca $ \(dimPtr :: Ptr Int32) -> do
        ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
cFnName) trexio dimPtr
        case ec of
          Success -> fromIntegral <$> peek dimPtr
          _ -> throwM ec
    )
    |]

isIntField :: Typ -> Bool
isIntField :: Typ -> Bool
isIntField (Dim Bool
_ Length
_) = Bool
True
isIntField (Int Length
_) = Bool
True
isIntField (Idx Length
_) = Bool
True
isIntField Typ
_ = Bool
False

isWritableIntField :: Typ -> Bool
isWritableIntField :: Typ -> Bool
isWritableIntField (Dim Bool
True Length
_) = Bool
True
isWritableIntField (Int Length
_) = Bool
True
isWritableIntField (Idx Length
_) = Bool
True
isWritableIntField Typ
_ = Bool
False

isProtectedIntField :: Typ -> Bool
isProtectedIntField :: Typ -> Bool
isProtectedIntField (Dim Bool
False Length
_) = Bool
True
isProtectedIntField Typ
_ = Bool
False

isFloatField :: Typ -> Bool
isFloatField :: Typ -> Bool
isFloatField (Float Bool
False Length
_) = Bool
True
isFloatField Typ
_ = Bool
False

isBufferedFloat :: Typ -> Bool
isBufferedFloat :: Typ -> Bool
isBufferedFloat (Float Bool
True Length
_) = Bool
True
isBufferedFloat Typ
_ = Bool
False

isSparseFloat :: Typ -> Bool
isSparseFloat :: Typ -> Bool
isSparseFloat (SparseFloat Length
_) = Bool
True
isSparseFloat Typ
_ = Bool
False

isStringField :: Typ -> Bool
isStringField :: Typ -> Bool
isStringField (Str Length
_) = Bool
True
isStringField Typ
_ = Bool
False

isBitField :: Typ -> Bool
isBitField :: Typ -> Bool
isBitField (BitField Length
_) = Bool
True
isBitField Typ
_ = Bool
False

{- | Sparse fields have an associated @_size@ function, that returns the number
of COO elements.
-}
mkCSizeFnName :: GroupName -> DataName -> String
mkCSizeFnName :: GroupName -> DataName -> String
mkCSizeFnName (GroupName Text
groupName) (DataName Text
dataName) =
  Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
    Text
"trexio_read_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
groupName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dataName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"

{- | Create abstracted read functions, that automatically obtain sizes for arrays
as required from other fields. 'CooArray's are read in a single, big chunk and
need to fit in memory.
-}
mkReadFns :: GroupName -> DataName -> Typ -> Q Exp
mkReadFns :: GroupName -> DataName -> Typ -> Q Exp
mkReadFns GroupName
groupName DataName
dataName Typ
fieldType = case [DimLength]
dims of
  []
    | Typ -> Bool
isIntField Typ
fieldType ->
        [e|
          \trexio -> liftIO . alloca $ \buf -> do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
            case ec of
              Success -> fromIntegral <$> peek buf
              _ -> throwM ec
          |]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio -> liftIO . alloca $ \buf -> do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
            case ec of
              Success -> peek (castPtr buf)
              _ -> throwM ec
          |]
    | Typ -> Bool
isStringField Typ
fieldType ->
        [e|
          \trexio -> liftIO . allocaBytes 256 $ \strPtr -> do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio strPtr 256
            case ec of
              Success -> T.pack <$> peekCString strPtr
              _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 0D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1]
    | Typ -> Bool
isIntField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            allocaArray sz1 $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> peekIntArray (Sz1 sz1) buf
                _ -> throwM ec
          |]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            allocaArray sz1 $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> peekArray (Sz1 sz1) (castPtr buf)
                _ -> throwM ec
          |]
    | Typ -> Bool
isStringField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            nStrings <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            let maxStrLen = 256

            -- Allocate nStrings buffers
            strFPtrs :: [ForeignPtr CChar] <- forM [0 .. nStrings - 1] $ \_ ->
              mallocForeignPtrArray maxStrLen
            let strPtrs :: [Ptr CChar] = unsafeForeignPtrToPtr <$> strFPtrs

            -- Allocate the vector storing the pointers to the buffers
            F.withArray strPtrs $ \(ptrPtr :: Ptr (Ptr CChar)) -> do
              -- Call C function
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio ptrPtr (fromIntegral maxStrLen)
              res <- case ec of
                Success -> do
                  cStrings <- F.peekArray nStrings ptrPtr
                  strings <- traverse peekCString cStrings
                  return . Massiv.fromList Seq . fmap T.pack $ strings
                _ -> throwM ec

              -- Clean up all foreign pointers explicitly
              forM_ strFPtrs $ \fptr -> finalizeForeignPtr fptr

              return res
          |]
    | Typ -> Bool
isBitField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            moNum <- $(DimLength -> Q Exp
mkSizeFn (DimLength -> Q Exp) -> DimLength -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> DimLength
Field (Text -> GroupName
GroupName Text
"mo") (Text -> DataName
DataName Text
"num")) trexio
            nDets <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            nInt64PerDet <- intsPerDet trexio

            -- Allocate a buffer
            allocaArray (nDets * nInt64PerDet * 2) $ \detBuf -> do
              let readDets :: IO (Matrix U (Bit, Bit))
                  readDets = do
                    -- Read each determinant individually
                    dets <- forM [0 .. nDets - 1] $ \i -> do
                      let upPtr = detBuf `plusPtr` (i * nInt64PerDet * 2 * sizeOf (undefined :: Int64))
                          downPtr = upPtr `plusPtr` (nInt64PerDet * sizeOf (undefined :: Int64))
                          nBytes = nInt64PerDet * sizeOf (undefined :: Int64)

                      upBS <- BS.unsafePackCStringLen (castPtr upPtr, nBytes)
                      downBS <- BS.unsafePackCStringLen (castPtr downPtr, nBytes)

                      let toDet =
                            compute @U
                              . Massiv.take moNum
                              . (Massiv.fromVector' Par (Sz $ nBytes * 8) :: BV.Vector Bit -> Vector U Bit)
                              . BV.cloneFromByteString
                          upDet = toDet upBS
                          downDet = toDet downBS

                      return $ Massiv.zip upDet downDet

                    compute <$> stackOuterSlicesM dets

              -- Call the C function and populate the buffer
              with (fromIntegral nDets) $ \bufSz -> do
                ec <-
                  exitCodeH
                    <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName)
                      trexio
                      0
                      bufSz
                      detBuf
                case ec of
                  Success -> readDets
                  End -> readDets
                  _ -> throwM ec
          |]
    | Typ -> Bool
isBufferedFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            with (fromIntegral sz1) $ \bufSz ->
              allocaArray sz1 $ \buf -> do
                ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz buf
                case ec of
                  Success -> peekArray (Sz1 sz1) (castPtr buf)
                  End -> peekArray (Sz1 sz1) (castPtr buf)
                  _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 1D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            allocaArray (sz1 * sz2) $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> peekArray (Sz2 sz1 sz2) (castPtr buf)
                _ -> throwM ec
          |]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            -- Size of the array
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio

            -- Number of COO elements in the sparse array
            nCoo <- alloca $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> fromIntegral <$> peek buf
                _ -> throwM ec

            -- Read the COO array in a single chunk
            with (fromIntegral nCoo) $ \bufSz ->
              allocaArray (nCoo * 2) $ \ixBuf ->
                allocaArray nCoo $ \valBuf -> do
                  ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz ixBuf valBuf
                  case ec of
                    Success -> do
                      ixs <- peek2DCoords (Sz1 nCoo) ixBuf
                      vals <- peekArray (Sz1 nCoo) . castPtr $ valBuf
                      mkCooArray (Sz2 sz1 sz2) ixs . compute @U $ vals
                    _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 2D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            sz3 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d3) trexio
            allocaArray (sz1 * sz2 * sz3) $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> peekArray (Sz3 sz1 sz2 sz3) (castPtr buf)
                _ -> throwM ec
          |]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            -- Size of the array
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            sz3 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d3) trexio

            -- Number of COO elements in the sparse array
            nCoo <- alloca $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> fromIntegral <$> peek buf
                _ -> throwM ec

            -- Read the COO array in a single chunk
            with (fromIntegral nCoo) $ \bufSz ->
              allocaArray (nCoo * 3) $ \ixBuf ->
                allocaArray nCoo $ \valBuf -> do
                  ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz ixBuf valBuf
                  case ec of
                    Success -> do
                      ixs <- peek3DCoords (Sz1 nCoo) ixBuf
                      vals <- peekArray (Sz1 nCoo) . castPtr $ valBuf
                      mkCooArray (Sz3 sz1 sz2 sz3) ixs . compute @U $ vals
                    _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 3D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            -- Size of the array
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            sz3 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d3) trexio
            sz4 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d4) trexio

            -- Number of COO elements in the sparse array
            nCoo <- alloca $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> fromIntegral <$> peek buf
                _ -> throwM ec

            -- Read the COO array in a single chunk
            with (fromIntegral nCoo) $ \bufSz ->
              allocaArray (nCoo * 4) $ \ixBuf ->
                allocaArray nCoo $ \valBuf -> do
                  ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz ixBuf valBuf
                  case ec of
                    Success -> do
                      ixs <- peek4DCoords (Sz1 nCoo) ixBuf
                      vals <- peekArray (Sz1 nCoo) . castPtr $ valBuf
                      mkCooArray (Sz4 sz1 sz2 sz3 sz4) ixs . compute @U $ vals
                    _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 4D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4, Item [DimLength]
d5, Item [DimLength]
d6]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            -- Size of the array
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            sz3 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d3) trexio
            sz4 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d4) trexio
            sz5 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d5) trexio
            sz6 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d6) trexio

            -- Number of COO elements in the sparse array
            nCoo <- alloca $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> fromIntegral <$> peek buf
                _ -> throwM ec

            -- Read the COO array in a single chunk
            with (fromIntegral nCoo) $ \bufSz ->
              allocaArray (nCoo * 6) $ \ixBuf ->
                allocaArray nCoo $ \valBuf -> do
                  ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz ixBuf valBuf
                  case ec of
                    Success -> do
                      ixs <- peek6DCoords (Sz1 nCoo) ixBuf
                      vals <- peekArray (Sz1 nCoo) . castPtr $ valBuf
                      mkCooArray (Sz $ sz1 :> sz2 :> sz3 :> sz4 :> sz5 :. sz6) ixs . compute @U $ vals
                    _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 6D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4, Item [DimLength]
d5, Item [DimLength]
d6, Item [DimLength]
d7, Item [DimLength]
d8]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio -> liftIO $ do
            -- Size of the array
            sz1 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d1) trexio
            sz2 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d2) trexio
            sz3 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d3) trexio
            sz4 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d4) trexio
            sz5 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d5) trexio
            sz6 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d6) trexio
            sz7 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d7) trexio
            sz8 <- $(DimLength -> Q Exp
mkSizeFn Item [DimLength]
DimLength
d8) trexio

            -- Number of COO elements in the sparse array
            nCoo <- alloca $ \buf -> do
              ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ GroupName -> DataName -> String
mkCSizeFnName GroupName
groupName DataName
dataName) trexio buf
              case ec of
                Success -> fromIntegral <$> peek buf
                _ -> throwM ec

            -- Read the COO array in a single chunk
            with (fromIntegral nCoo) $ \bufSz ->
              allocaArray (nCoo * 8) $ \ixBuf ->
                allocaArray nCoo $ \valBuf -> do
                  ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Read GroupName
groupName DataName
dataName) trexio 0 bufSz ixBuf valBuf
                  case ec of
                    Success -> do
                      ixs <- peek8DCoords (Sz1 nCoo) ixBuf
                      vals <- peekArray (Sz1 nCoo) . castPtr $ valBuf
                      mkCooArray (Sz $ sz1 :> sz2 :> sz3 :> sz4 :> sz5 :> sz6 :> sz7 :. sz8) ixs . compute @U $ vals
                    _ -> throwM ec
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported field type for 8D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [DimLength]
dl -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkReadFns: unsupported number of dimensions: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [DimLength] -> String
forall a. Show a => a -> String
show [DimLength]
dl
 where
  dims :: [DimLength]
dims = Typ -> [DimLength]
getCrossRefs Typ
fieldType

-- | Get the Length specifications of a field
getCrossRefs :: Typ -> [DimLength]
getCrossRefs :: Typ -> [DimLength]
getCrossRefs (Dim Bool
_ (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (Int (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (Float Bool
_ (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (Str (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (Idx (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (SparseFloat (Length [DimLength]
lspec)) = [DimLength]
lspec
getCrossRefs (BitField (Length [DimLength]
lspec)) = [DimLength]
lspec

{- | Make a Read function for a given field. This generator takes care to query
referenced 'Dim' fields to obtain the correct size of the result. If any
of this 'Dim' fields is not set, the function will fail.
-}
mkHsReadFn :: GroupName -> DataName -> Typ -> Q [Dec]
mkHsReadFn :: GroupName -> DataName -> Typ -> Q [Dec]
mkHsReadFn GroupName
groupName DataName
dataName Typ
fieldTyp = do
  -- Generate the function name for Haskell
  let hsFnName :: String
hsFnName = FieldOps -> GroupName -> DataName -> String
mkHsFnName FieldOps
Read GroupName
groupName DataName
dataName

  -- Generate the Haskell function
  Type
hsFnSig <- FieldOps -> Typ -> Q Type
mkHsFnSig FieldOps
Read Typ
fieldTyp
  Exp
hsExp <- GroupName -> DataName -> Typ -> Q Exp
mkReadFns GroupName
groupName DataName
dataName Typ
fieldTyp
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Name -> Type -> Dec
SigD (String -> Name
mkName String
hsFnName) Type
hsFnSig
    , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
hsFnName) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
hsExp) []]
    ]

-- | Make a writer function for a given 'DimLength'.
mkWriteSzFn :: TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn :: TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
_ (Const Int
i) = [e|\_ _ -> return i|]
mkWriteSzFn (TrexioScheme Map GroupName Group
scheme) dimLength :: DimLength
dimLength@(Field GroupName
groupName DataName
dataName)
  | Bool
isReadOnly = [e|\_ _ -> return ()|]
  | Bool
otherwise = do
      let cFnName :: String
cFnName = FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName
      [e|
        \trexio sz -> liftIO $ do
          ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
cFnName) trexio (fromIntegral sz)
          case ec of
            Success -> return ()
            ReadOnly -> return ()
            -- If the attribute already exists, read it and check if it is the
            -- same value we want to write
            AttrAlreadyExists -> do
              currentSz <- $(DimLength -> Q Exp
mkSizeFn DimLength
dimLength) trexio
              if currentSz == sz
                then return ()
                else throwM AttrAlreadyExists
            _ -> throwM ec
        |]
 where
  Group Map DataName Typ
grp = Map GroupName Group
scheme Map GroupName Group -> GroupName -> Group
forall k a. Ord k => Map k a -> k -> a
Map.! GroupName
groupName
  fieldTyp :: Typ
fieldTyp = Map DataName Typ
grp Map DataName Typ -> DataName -> Typ
forall k a. Ord k => Map k a -> k -> a
Map.! DataName
dataName
  isReadOnly :: Bool
isReadOnly = case Typ
fieldTyp of
    Dim Bool
False Length
_ -> Bool
True
    Typ
_ -> Bool
False

-- | Make a writer function for a given field
mkWriteFns :: TrexioScheme -> GroupName -> DataName -> Typ -> Q Exp
mkWriteFns :: TrexioScheme -> GroupName -> DataName -> Typ -> Q Exp
mkWriteFns TrexioScheme
scheme GroupName
groupName DataName
dataName Typ
fieldType = case [DimLength]
dims of
  []
    | Typ -> Bool
isWritableIntField Typ
fieldType ->
        [e|
          \trexio int -> liftIO $ do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (fromIntegral int)
            case ec of
              Success -> return ()
              _ -> throwM ec
          |]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio float -> liftIO $ do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (coerce float)
            case ec of
              Success -> return ()
              _ -> throwM ec
          |]
    | Typ -> Bool
isStringField Typ
fieldType ->
        [e|
          \trexio str -> liftIO . withCStringLen (T.unpack str) $ \(strPtr, len) -> do
            ec <- exitCodeH <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (ConstPtr strPtr) (fromIntegral len)
            case ec of
              Success -> return ()
              _ -> throwM ec
          |]
    | Typ -> Bool
isProtectedIntField Typ
fieldType -> [e|\_ _ -> return ()|]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 0D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1]
    | Typ -> Bool
isIntField Typ
fieldType ->
        [e|
          \trexio arr -> liftIO . unsafeWithPtr (compute . Massiv.map fromIntegral $ arr) $ \arrPtr -> do
            let Sz1 sz1 = size arr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio arrPtr
          |]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio arr -> liftIO . unsafeWithPtr arr $ \arrPtr -> do
            let Sz1 sz1 = size arr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (castPtr arrPtr)
          |]
    | Typ -> Bool
isStringField Typ
fieldType ->
        [e|
          \trexio arr -> liftIO $ do
            let Sz1 nStrings = size arr
                maxStrLen = 255
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio nStrings
            ptrArr <- compute <$> mapM (fmap ConstPtr . newCString . T.unpack) arr
            unsafeWithPtr ptrArr $ \arrPtr ->
              checkEC $
                $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                  trexio
                  (ConstPtr arrPtr)
                  maxStrLen
          |]
    | Typ -> Bool
isBitField Typ
fieldType ->
        [e|
          \trexio dets -> liftIO $ do
            nInt64PerDet <- intsPerDet trexio
            let Sz2 nDets _nMos = size dets
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio nDets

            allocaArray (nDets * nInt64PerDet * 2) $ \detBuf -> do
              -- Write each determinant to the buffer
              forM_ [0 .. nDets - 1] $ \i -> do
                let det = dets !> i
                    detToByteString bv accFn =
                      BV.cloneToByteString
                        . Massiv.toVector
                        . compute @U
                        . Massiv.map accFn
                        $ bv
                    up = detToByteString det fst
                    down = detToByteString det snd
                    nBytes = BS.length up
                    upPtr = detBuf `plusPtr` (i * nInt64PerDet * 2 * sizeOf (undefined :: Int64))
                    downPtr = upPtr `plusPtr` (nInt64PerDet * sizeOf (undefined :: Int64))

                -- Up spin
                BS.unsafeUseAsCString up $ \charPtr -> do
                  copyBytes (castPtr upPtr) charPtr nBytes

                -- Down spin
                BS.unsafeUseAsCString down $ \charPtr -> do
                  copyBytes (castPtr downPtr) charPtr nBytes

              -- Call the C funciton with the buffer
              checkEC $
                $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                  trexio
                  0
                  (fromIntegral nDets)
                  detBuf
          |]
    | Typ -> Bool
isBufferedFloat Typ
fieldType ->
        [e|
          \trexio vec -> liftIO $ do
            let Sz1 sz1 = size vec
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            unsafeWithPtr vec $ \arrPtr ->
              checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio 0 (fromIntegral sz1) (castPtr arrPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 1D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio arr -> liftIO . unsafeWithPtr arr $ \arrPtr -> do
            let Sz2 sz1 sz2 = size arr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (castPtr arrPtr)
          |]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio cooArr -> liftIO $ do
            let Sz2 sz1 sz2 = cooSize cooArr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            let cooVals = convert . values $ cooArr :: Vector S Double
                cooIxs = castCoords2D . coords $ cooArr :: Matrix S Int32
                Sz1 nCoo = size cooVals
            unsafeWithPtr cooVals $ \valPtr ->
              unsafeWithPtr cooIxs $ \ixPtr -> do
                checkEC $
                  $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                    trexio
                    0
                    (fromIntegral nCoo :: Int64)
                    ixPtr
                    (castPtr valPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 2D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3]
    | Typ -> Bool
isFloatField Typ
fieldType ->
        [e|
          \trexio arr -> liftIO . unsafeWithPtr arr $ \arrPtr -> do
            let Sz3 sz1 sz2 sz3 = size arr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d3) trexio sz3
            checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName) trexio (castPtr arrPtr)
          |]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio cooArr -> liftIO $ do
            let Sz3 sz1 sz2 sz3 = cooSize cooArr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d3) trexio sz3
            let cooVals = convert . values $ cooArr
                cooIxs = castCoords3D . coords $ cooArr
                Sz1 nCoo = size cooVals
            unsafeWithPtr cooVals $ \valPtr ->
              unsafeWithPtr cooIxs $ \ixPtr ->
                checkEC $
                  $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                    trexio
                    0
                    (fromIntegral nCoo)
                    ixPtr
                    (castPtr valPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 3D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio cooArr -> liftIO $ do
            let Sz4 sz1 sz2 sz3 sz4 = cooSize cooArr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d3) trexio sz3
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d4) trexio sz4
            let cooVals = convert . values $ cooArr
                cooIxs = castCoords4D . coords $ cooArr
                Sz1 nCoo = size cooVals
            unsafeWithPtr cooVals $ \valPtr ->
              unsafeWithPtr cooIxs $ \ixPtr ->
                checkEC $
                  $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                    trexio
                    0
                    (fromIntegral nCoo)
                    ixPtr
                    (castPtr valPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 4D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4, Item [DimLength]
d5, Item [DimLength]
d6]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio cooArr -> liftIO $ do
            let Sz (sz1 :> sz2 :> sz3 :> sz4 :> sz5 :. sz6) = cooSize cooArr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d3) trexio sz3
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d4) trexio sz4
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d5) trexio sz5
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d6) trexio sz6
            let cooVals = convert . values $ cooArr
                cooIxs = castCoords6D . coords $ cooArr
                Sz1 nCoo = size cooVals
            unsafeWithPtr cooVals $ \valPtr ->
              unsafeWithPtr cooIxs $ \ixPtr ->
                checkEC $
                  $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                    trexio
                    0
                    (fromIntegral nCoo)
                    ixPtr
                    (castPtr valPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 6D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [Item [DimLength]
d1, Item [DimLength]
d2, Item [DimLength]
d3, Item [DimLength]
d4, Item [DimLength]
d5, Item [DimLength]
d6, Item [DimLength]
d7, Item [DimLength]
d8]
    | Typ -> Bool
isSparseFloat Typ
fieldType ->
        [e|
          \trexio cooArr -> liftIO $ do
            let Sz (sz1 :> sz2 :> sz3 :> sz4 :> sz5 :> sz6 :> sz7 :. sz8) = cooSize cooArr
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d1) trexio sz1
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d2) trexio sz2
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d3) trexio sz3
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d4) trexio sz4
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d5) trexio sz5
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d6) trexio sz6
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d7) trexio sz7
            $(TrexioScheme -> DimLength -> Q Exp
mkWriteSzFn TrexioScheme
scheme Item [DimLength]
DimLength
d8) trexio sz8
            let cooVals = convert . values $ cooArr
                cooIxs = castCoords8D . coords $ cooArr
                Sz1 nCoo = size cooVals
            unsafeWithPtr cooVals $ \valPtr ->
              unsafeWithPtr cooIxs $ \ixPtr ->
                checkEC $
                  $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ FieldOps -> GroupName -> DataName -> String
mkCFnName FieldOps
Write GroupName
groupName DataName
dataName)
                    trexio
                    0
                    (fromIntegral nCoo)
                    ixPtr
                    (castPtr valPtr)
          |]
    | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported field type for 8D data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Typ -> String
forall a. Show a => a -> String
show Typ
fieldType
  [DimLength]
dl -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkWriteFns: unsupported number of dimensions: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [DimLength] -> String
forall a. Show a => a -> String
show [DimLength]
dl
 where
  dims :: [DimLength]
dims = Typ -> [DimLength]
getCrossRefs Typ
fieldType

mkHsWriteFn :: TrexioScheme -> GroupName -> DataName -> Typ -> Q [Dec]
mkHsWriteFn :: TrexioScheme -> GroupName -> DataName -> Typ -> Q [Dec]
mkHsWriteFn TrexioScheme
scheme GroupName
groupName DataName
dataName Typ
fieldTyp = do
  -- Generate the function names in C and Haskell
  let hsFnName :: String
hsFnName = FieldOps -> GroupName -> DataName -> String
mkHsFnName FieldOps
Write GroupName
groupName DataName
dataName

  -- Generate the Haskell function
  Type
hsFnSig <- FieldOps -> Typ -> Q Type
mkHsFnSig FieldOps
Write Typ
fieldTyp
  Exp
hsExp <- TrexioScheme -> GroupName -> DataName -> Typ -> Q Exp
mkWriteFns TrexioScheme
scheme GroupName
groupName DataName
dataName Typ
fieldTyp
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Name -> Type -> Dec
SigD (String -> Name
mkName String
hsFnName) Type
hsFnSig
    , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
hsFnName) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
hsExp) []]
    ]

mkCDeleteName :: GroupName -> String
mkCDeleteName :: GroupName -> String
mkCDeleteName (GroupName Text
groupName) = String
"trexio_delete_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
groupName

mkHsDeleteName :: GroupName -> String
mkHsDeleteName :: GroupName -> String
mkHsDeleteName (GroupName Text
groupName) = ShowS
sanId ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
camel ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"delete_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
groupName

mkCDeleteFn :: GroupName -> Q Dec
mkCDeleteFn :: GroupName -> Q Dec
mkCDeleteFn GroupName
groupName = do
  let cFnName :: String
cFnName = GroupName -> String
mkCDeleteName GroupName
groupName
  Type
cTyp <- [t|Trexio -> IO ExitCodeC|]
  Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> (Foreign -> Dec) -> Foreign -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Dec
ForeignD (Foreign -> Q Dec) -> Foreign -> Q Dec
forall a b. (a -> b) -> a -> b
$ Callconv -> Safety -> String -> Name -> Type -> Foreign
ImportF Callconv
CApi Safety
Unsafe (String
"trexio.h " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cFnName) (String -> Name
mkName String
cFnName) Type
cTyp

mkHsDeleteFn :: GroupName -> Q [Dec]
mkHsDeleteFn :: GroupName -> Q [Dec]
mkHsDeleteFn GroupName
groupName = do
  let cFnName :: Name
cFnName = String -> Name
mkName (String -> Name) -> (GroupName -> String) -> GroupName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupName -> String
mkCDeleteName (GroupName -> Name) -> GroupName -> Name
forall a b. (a -> b) -> a -> b
$ GroupName
groupName
      hsFnName :: Name
hsFnName = String -> Name
mkName (String -> Name) -> (GroupName -> String) -> GroupName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupName -> String
mkHsDeleteName (GroupName -> Name) -> GroupName -> Name
forall a b. (a -> b) -> a -> b
$ GroupName
groupName
  Type
hsTyp <- [t|forall m. (MonadIO m) => Trexio -> m ()|]
  Exp
hsFn <- [e|\trexio -> liftIO . checkEC $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
cFnName) trexio|]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Name -> Type -> Dec
SigD Name
hsFnName Type
hsTyp
    , Name -> [Clause] -> Dec
FunD Name
hsFnName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
hsFn) []]
    ]