{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}

{- |
Module      : DataFrame.Typed.TH.Records
License     : MIT

Record-based typed-API schema derivation. The IO-agnostic core of the
@DataFrame.Typed.TH@ family. CSV-file-based derivation lives in
"DataFrame.Typed.TH.CSV" (in @dataframe-csv-th@).
-}
module DataFrame.Typed.TH.Records (
    -- * Schema inference from an existing DataFrame value
    deriveSchema,

    -- * ADT-based schema derivation
    deriveSchemaFromType,
    deriveSchemaFromTypeWith,
    deriveSchemaValues,
    SchemaOptions (..),
    defaultSchemaOptions,
    camelToSnake,

    -- * Re-export for TH splices
    TypedDataFrame,

    -- * Shared helpers (used by sibling TH modules)
    getSchemaInfo,
    findDuplicate,
) where

import Control.Monad (when)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Vector as VB

import Language.Haskell.TH

import qualified DataFrame.Internal.Column as C
import qualified DataFrame.Internal.DataFrame as D
import qualified DataFrame.Internal.Schema.TH as SchemaTH
import DataFrame.Typed.Record (
    HasSchema,
    Schema,
    fromColumns,
    requireColumn,
    toColumns,
 )
import DataFrame.Typed.Types (TypedDataFrame)
import DataFrame.Typed.Util (camelToSnake)

{- | Derive an untyped 'DataFrame.Schema.Schema' value plus per-column 'Expr'
accessors from a record type. The value-level companion to
'deriveSchemaFromType': @$(deriveSchemaValues ''Order)@ generates @orderSchema@.
-}
deriveSchemaValues :: Name -> DecsQ
deriveSchemaValues :: Name -> DecsQ
deriveSchemaValues = Name -> DecsQ
SchemaTH.deriveSchema

deriveSchema :: String -> D.DataFrame -> DecsQ
deriveSchema :: [Char] -> DataFrame -> DecsQ
deriveSchema [Char]
typeName DataFrame
df = do
    let cols :: [(Text, [Char])]
cols = DataFrame -> [(Text, [Char])]
getSchemaInfo DataFrame
df
    let names :: [Text]
names = ((Text, [Char]) -> Text) -> [(Text, [Char])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [Char]) -> Text
forall a b. (a, b) -> a
fst [(Text, [Char])]
cols
    case [Text] -> Maybe Text
forall a. Eq a => [a] -> Maybe a
findDuplicate [Text]
names of
        Just Text
dup -> [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Duplicate column name in DataFrame: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
dup
        Maybe Text
Nothing -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Type]
colTypes <- ((Text, [Char]) -> Q Type) -> [(Text, [Char])] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text, [Char]) -> Q Type
mkColumnType [(Text, [Char])]
cols
    let schemaType :: Type
schemaType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
t Type
acc -> Type
PromotedConsT Type -> Type -> Type
`AppT` Type
t Type -> Type -> Type
`AppT` Type
acc) Type
PromotedNilT [Type]
colTypes
    let synName :: Name
synName = [Char] -> Name
mkName [Char]
typeName
    [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD Name
synName [] Type
schemaType]

getSchemaInfo :: D.DataFrame -> [(T.Text, String)]
getSchemaInfo :: DataFrame -> [(Text, [Char])]
getSchemaInfo DataFrame
df =
    let orderedNames :: [Text]
orderedNames =
            ((Text, Int) -> Text) -> [(Text, Int)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Text
forall a b. (a, b) -> a
fst ([(Text, Int)] -> [Text]) -> [(Text, Int)] -> [Text]
forall a b. (a -> b) -> a -> b
$
                ((Text, Int) -> (Text, Int) -> Ordering)
-> [(Text, Int)] -> [(Text, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (\(Text
_, Int
a) (Text
_, Int
b) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
b) ([(Text, Int)] -> [(Text, Int)]) -> [(Text, Int)] -> [(Text, Int)]
forall a b. (a -> b) -> a -> b
$
                    Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
M.toList (DataFrame -> Map Text Int
D.columnIndices DataFrame
df)
     in (Text -> (Text, [Char])) -> [Text] -> [(Text, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
name -> (Text
name, Text -> DataFrame -> [Char]
getColumnTypeStr Text
name DataFrame
df)) [Text]
orderedNames

getColumnTypeStr :: T.Text -> D.DataFrame -> String
getColumnTypeStr :: Text -> DataFrame -> [Char]
getColumnTypeStr Text
name DataFrame
df = case Text -> DataFrame -> Maybe Column
D.getColumn Text
name DataFrame
df of
    Just Column
col -> Column -> [Char]
C.columnTypeString Column
col
    Maybe Column
Nothing -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Column not found: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name

mkColumnType :: (T.Text, String) -> Q Type
mkColumnType :: (Text, [Char]) -> Q Type
mkColumnType (Text
name, [Char]
tyStr) = do
    Type
ty <- [Char] -> Q Type
parseTypeString [Char]
tyStr
    let nameLit :: Type
nameLit = TyLit -> Type
LitT ([Char] -> TyLit
StrTyLit (Text -> [Char]
T.unpack Text
name))
    Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
PromotedTupleT Int
2 Type -> Type -> Type
`AppT` Type
nameLit Type -> Type -> Type
`AppT` Type
ty

parseTypeString :: String -> Q Type
parseTypeString :: [Char] -> Q Type
parseTypeString [Char]
"Int" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Int
parseTypeString [Char]
"Double" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Double
parseTypeString [Char]
"Float" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Float
parseTypeString [Char]
"Bool" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Bool
parseTypeString [Char]
"Char" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Char
parseTypeString [Char]
"String" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''String
parseTypeString [Char]
"Text" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''T.Text
parseTypeString [Char]
"Integer" = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Integer
parseTypeString [Char]
s
    | [Char]
"Maybe " [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [Char]
s = do
        Type
inner <- [Char] -> Q Type
parseTypeString (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
L.drop Int
6 [Char]
s)
        Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Type
inner
parseTypeString [Char]
s = [Char] -> Q Type
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Type) -> [Char] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported column type in schema inference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

findDuplicate :: (Eq a) => [a] -> Maybe a
findDuplicate :: forall a. Eq a => [a] -> Maybe a
findDuplicate [] = Maybe a
forall a. Maybe a
Nothing
findDuplicate (a
x : [a]
xs)
    | a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    | Bool
otherwise = [a] -> Maybe a
forall a. Eq a => [a] -> Maybe a
findDuplicate [a]
xs

-- | Options controlling 'deriveSchemaFromTypeWith'.
data SchemaOptions = SchemaOptions
    { SchemaOptions -> [Char] -> [Char]
nameTransform :: String -> String
    -- ^ Map each record selector name to a column name. Default: 'camelToSnake'.
    , SchemaOptions -> Maybe [Char]
schemaTypeName :: Maybe String
    -- ^ Override the generated type synonym name. Default: @\<TypeName\>Schema@.
    , SchemaOptions -> Bool
generateInstance :: Bool
    {- ^ When @True@ (default), also generate a 'HasSchema' instance so the
    record can be turned into a 'DataFrame' via 'fromRecords' / 'toRecords'.
    -}
    }

defaultSchemaOptions :: SchemaOptions
defaultSchemaOptions :: SchemaOptions
defaultSchemaOptions =
    SchemaOptions
        { nameTransform :: [Char] -> [Char]
nameTransform = [Char] -> [Char]
camelToSnake
        , schemaTypeName :: Maybe [Char]
schemaTypeName = Maybe [Char]
forall a. Maybe a
Nothing
        , generateInstance :: Bool
generateInstance = Bool
True
        }

deriveSchemaFromType :: Name -> DecsQ
deriveSchemaFromType :: Name -> DecsQ
deriveSchemaFromType = SchemaOptions -> Name -> DecsQ
deriveSchemaFromTypeWith SchemaOptions
defaultSchemaOptions

deriveSchemaFromTypeWith :: SchemaOptions -> Name -> DecsQ
deriveSchemaFromTypeWith :: SchemaOptions -> Name -> DecsQ
deriveSchemaFromTypeWith SchemaOptions
opts Name
tyName = do
    Info
info <- Name -> Q Info
reify Name
tyName
    (Name
conName, [VarBangType]
vbts) <- Name -> Info -> Q (Name, [VarBangType])
extractRecord Name
tyName Info
info
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([VarBangType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [VarBangType]
vbts) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$
            [Char]
"deriveSchemaFromType: record "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tyName
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" has no fields"
    let fields :: [([Char], Name, Type)]
fields =
            [ (SchemaOptions -> [Char] -> [Char]
nameTransform SchemaOptions
opts (Name -> [Char]
nameBase Name
fName), Name
fName, Type
ty)
            | (Name
fName, Bang
_bang, Type
ty) <- [VarBangType]
vbts
            ]
        colNames :: [[Char]]
colNames = [[Char]
c | ([Char]
c, Name
_, Type
_) <- [([Char], Name, Type)]
fields]
    case [[Char]] -> Maybe [Char]
forall a. Eq a => [a] -> Maybe a
findDuplicate [[Char]]
colNames of
        Just [Char]
dup ->
            [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$
                [Char]
"deriveSchemaFromType: duplicate transformed column name "
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
dup
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (consider customizing nameTransform via deriveSchemaFromTypeWith)"
        Maybe [Char]
Nothing -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    let synName :: Name
synName = case SchemaOptions -> Maybe [Char]
schemaTypeName SchemaOptions
opts of
            Just [Char]
s -> [Char] -> Name
mkName [Char]
s
            Maybe [Char]
Nothing -> [Char] -> Name
mkName (Name -> [Char]
nameBase Name
tyName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Schema")
    let columnTypes :: [Type]
columnTypes =
            [ Int -> Type
PromotedTupleT Int
2 Type -> Type -> Type
`AppT` TyLit -> Type
LitT ([Char] -> TyLit
StrTyLit [Char]
colName) Type -> Type -> Type
`AppT` Type
ty
            | ([Char]
colName, Name
_, Type
ty) <- [([Char], Name, Type)]
fields
            ]
        schemaType :: Type
schemaType =
            (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                (\Type
t Type
acc -> Type
PromotedConsT Type -> Type -> Type
`AppT` Type
t Type -> Type -> Type
`AppT` Type
acc)
                Type
PromotedNilT
                [Type]
columnTypes
        synDec :: Dec
synDec = Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD Name
synName [] Type
schemaType
    if SchemaOptions -> Bool
generateInstance SchemaOptions
opts
        then do
            Dec
inst <- Name -> Type -> Name -> [([Char], Name, Type)] -> Q Dec
mkHasSchemaInstance Name
tyName Type
schemaType Name
conName [([Char], Name, Type)]
fields
            [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
synDec, Dec
inst]
        else [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
synDec]

extractRecord :: Name -> Info -> Q (Name, [VarBangType])
extractRecord :: Name -> Info -> Q (Name, [VarBangType])
extractRecord Name
_ (TyConI Dec
dec) = case Dec
dec of
    DataD [Type]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [RecC Name
conName [VarBangType]
fs] [DerivClause]
_ -> (Name, [VarBangType]) -> Q (Name, [VarBangType])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
conName, [VarBangType]
fs)
    NewtypeD [Type]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ (RecC Name
conName [VarBangType]
fs) [DerivClause]
_ -> (Name, [VarBangType]) -> Q (Name, [VarBangType])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
conName, [VarBangType]
fs)
    DataD [Type]
_ Name
name [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
_ [DerivClause]
_ ->
        [Char] -> Q (Name, [VarBangType])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (Name, [VarBangType]))
-> [Char] -> Q (Name, [VarBangType])
forall a b. (a -> b) -> a -> b
$
            [Char]
"deriveSchemaFromType: "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" must have exactly one record constructor"
    NewtypeD [Type]
_ Name
name [TyVarBndr BndrVis]
_ Maybe Type
_ Con
_ [DerivClause]
_ ->
        [Char] -> Q (Name, [VarBangType])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (Name, [VarBangType]))
-> [Char] -> Q (Name, [VarBangType])
forall a b. (a -> b) -> a -> b
$
            [Char]
"deriveSchemaFromType: "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" newtype must use record syntax"
    Dec
other ->
        [Char] -> Q (Name, [VarBangType])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (Name, [VarBangType]))
-> [Char] -> Q (Name, [VarBangType])
forall a b. (a -> b) -> a -> b
$
            [Char]
"deriveSchemaFromType: unsupported declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Dec -> [Char]
forall a. Show a => a -> [Char]
show Dec
other
extractRecord Name
tyName Info
_ =
    [Char] -> Q (Name, [VarBangType])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (Name, [VarBangType]))
-> [Char] -> Q (Name, [VarBangType])
forall a b. (a -> b) -> a -> b
$
        [Char]
"deriveSchemaFromType: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tyName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a data/newtype declaration"

mkHasSchemaInstance ::
    Name -> Type -> Name -> [(String, Name, Type)] -> Q Dec
mkHasSchemaInstance :: Name -> Type -> Name -> [([Char], Name, Type)] -> Q Dec
mkHasSchemaInstance Name
tyName Type
schemaType Name
conName [([Char], Name, Type)]
fields = do
    Clause
toClause <- [([Char], Name, Type)] -> Q Clause
mkToColumnsClause [([Char], Name, Type)]
fields
    Clause
fromClause <- Name -> [([Char], Name, Type)] -> Q Clause
mkFromColumnsClause Name
conName [([Char], Name, Type)]
fields
    let instType :: Type
instType = Name -> Type
ConT ''HasSchema Type -> Type -> Type
`AppT` Name -> Type
ConT Name
tyName
        schemaInst :: Dec
schemaInst =
            TySynEqn -> Dec
TySynInstD
                (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Name -> Type
ConT ''Schema Type -> Type -> Type
`AppT` Name -> Type
ConT Name
tyName) Type
schemaType)
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
        Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
            Maybe Overlap
forall a. Maybe a
Nothing
            []
            Type
instType
            [ Dec
schemaInst
            , Name -> [Clause] -> Dec
FunD 'toColumns [Clause
toClause]
            , Name -> [Clause] -> Dec
FunD 'fromColumns [Clause
fromClause]
            ]

mkToColumnsClause :: [(String, Name, Type)] -> Q Clause
mkToColumnsClause :: [([Char], Name, Type)] -> Q Clause
mkToColumnsClause [([Char], Name, Type)]
fields = do
    Name
rs <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rs"
    let mkPair :: ([Char], Name, c) -> Exp
mkPair ([Char]
colName, Name
fieldFn, c
_ty) =
            let nameE :: Exp
nameE = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) (Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
colName))
                colE :: Exp
colE =
                    Exp -> Exp -> Exp
AppE
                        (Name -> Exp
VarE 'C.fromList)
                        ( Exp -> Exp -> Exp
AppE
                            (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'map) (Name -> Exp
VarE Name
fieldFn))
                            (Name -> Exp
VarE Name
rs)
                        )
             in [Maybe Exp] -> Exp
TupE [Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
nameE, Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
colE]
        listExp :: Exp
listExp = [Exp] -> Exp
ListE ((([Char], Name, Type) -> Exp) -> [([Char], Name, Type)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Name, Type) -> Exp
forall {c}. ([Char], Name, c) -> Exp
mkPair [([Char], Name, Type)]
fields)
    Clause -> Q Clause
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
rs] (Exp -> Body
NormalB Exp
listExp) []

mkFromColumnsClause :: Name -> [(String, Name, Type)] -> Q Clause
mkFromColumnsClause :: Name -> [([Char], Name, Type)] -> Q Clause
mkFromColumnsClause Name
conName [([Char], Name, Type)]
fields = do
    Name
df <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"df"
    Name
iN <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"i"
    Name
nN <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"n"
    [Name]
vNames <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
k -> [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName ([Char]
"v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
k :: Int))) [Int
0 .. [([Char], Name, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], Name, Type)]
fields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    let mkBind :: Name -> ([Char], b, Type) -> Stmt
mkBind Name
v ([Char]
colName, b
_, Type
ty) =
            let nameE :: Exp
nameE = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) (Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
colName))
                callE :: Exp
callE =
                    Exp -> Exp -> Exp
AppE
                        ( Exp -> Exp -> Exp
AppE
                            (Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'requireColumn) Type
ty)
                            Exp
nameE
                        )
                        (Name -> Exp
VarE Name
df)
             in Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP Name
v) Exp
callE
        binds :: [Stmt]
binds = (Name -> ([Char], Name, Type) -> Stmt)
-> [Name] -> [([Char], Name, Type)] -> [Stmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> ([Char], Name, Type) -> Stmt
forall {b}. Name -> ([Char], b, Type) -> Stmt
mkBind [Name]
vNames [([Char], Name, Type)]
fields
        firstV :: Name
firstV = case [Name]
vNames of
            (Name
v0 : [Name]
_) -> Name
v0
            [] -> [Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"mkFromColumnsClause: empty fields (should have failed earlier)"
        lengthBind :: Stmt
lengthBind =
            [Dec] -> Stmt
LetS
                [ Pat -> Body -> [Dec] -> Dec
ValD
                    (Name -> Pat
VarP Name
nN)
                    (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'VB.length) (Name -> Exp
VarE Name
firstV)))
                    []
                ]
        indexE :: Name -> Exp
indexE Name
v =
            Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'VB.unsafeIndex) (Name -> Exp
VarE Name
v)) (Name -> Exp
VarE Name
iN)
        elemE :: Exp
elemE =
            (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                (\Exp
acc Name
v -> Exp -> Exp -> Exp
AppE Exp
acc (Name -> Exp
indexE Name
v))
                (Name -> Exp
ConE Name
conName)
                [Name]
vNames
        nMinus1E :: Exp
nMinus1E =
            Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
nN))
                (Name -> Exp
VarE '(-))
                (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
1)))
        rangeE :: Exp
rangeE = Range -> Exp
ArithSeqE (Exp -> Exp -> Range
FromToR (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
0)) Exp
nMinus1E)
        compExp :: Exp
compExp = [Stmt] -> Exp
CompE [Pat -> Exp -> Stmt
BindS (Name -> Pat
VarP Name
iN) Exp
rangeE, Exp -> Stmt
NoBindS Exp
elemE]
        rightE :: Exp
rightE = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Right) Exp
compExp
        body :: Exp
body = Maybe ModName -> [Stmt] -> Exp
DoE Maybe ModName
forall a. Maybe a
Nothing ([Stmt]
binds [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
lengthBind, Exp -> Stmt
NoBindS Exp
rightE])
    Clause -> Q Clause
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
df] (Exp -> Body
NormalB Exp
body) []