diff --git a/dataframe-th.cabal b/dataframe-th.cabal --- a/dataframe-th.cabal +++ b/dataframe-th.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: dataframe-th -version: 2.2.1.0 +version: 2.3.0.0 synopsis: Record-based Template Haskell splices for the dataframe ecosystem. description: The IO-agnostic part of the @dataframe@ TH machinery — splices that @@ -34,11 +34,12 @@ other-modules: DataFrame.Internal.Schema.TH build-depends: base >= 4 && < 5, containers >= 0.6.7 && < 0.10, - dataframe-core >= 2.5 && < 2.6, - dataframe-operations >= 2.5 && < 2.6, + dataframe-core >= 2.6 && < 2.7, + dataframe-operations >= 2.6 && < 2.7, dataframe-parsing >= 2.2 && < 2.3, template-haskell >= 2.0 && < 3, text >= 2.1 && < 3, + time >= 1.12 && < 2, vector >= 0.13 && < 0.15 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/DataFrame/Internal/Schema/TH.hs b/src/DataFrame/Internal/Schema/TH.hs --- a/src/DataFrame/Internal/Schema/TH.hs +++ b/src/DataFrame/Internal/Schema/TH.hs @@ -3,28 +3,27 @@ {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeApplications #-} -{- | -Template-Haskell @deriveSchema@ splice for "DataFrame.Internal.Schema". -Kept in a separate module so the runtime schema types in -"DataFrame.Internal.Schema" do not pull in @template-haskell@. --} +-- | Template-Haskell @deriveSchema@ splice for "DataFrame.Internal.Schema". module DataFrame.Internal.Schema.TH ( deriveSchema, + schemaTypeE, camelToSnake, ) where import Data.Char (isUpper, toLower, toUpper) +import qualified Data.Proxy as P import qualified Data.Text as T import Language.Haskell.TH import DataFrame.Expression.Operators (col) import DataFrame.Internal.Expression (Expr) -import DataFrame.Schema (Schema, makeSchema, schemaType) +import DataFrame.Schema (Schema, SchemaType (..), makeSchema) -{- | Auto-generate a runtime 'Schema' (and per-column @'Expr'@ accessors) -from a record ADT. Emits @\Schema@ plus one accessor per field -(@camelCase -> snake_case@). Requires a single record constructor. --} +schemaTypeE :: Type -> Exp +schemaTypeE ty = + ConE 'SType `AppE` SigE (ConE 'P.Proxy) (ConT ''P.Proxy `AppT` ty) + +-- | Auto-generate a runtime 'Schema' and per-column accessors from a record. deriveSchema :: Name -> DecsQ deriveSchema tyName = do info <- reify tyName @@ -39,7 +38,7 @@ tupleE (colName, _, fTy) = TupE [ Just (AppE (VarE 'T.pack) (LitE (StringL colName))) - , Just (AppTypeE (VarE 'schemaType) fTy) + , Just (schemaTypeE fTy) ] schemaBody = AppE (VarE 'makeSchema) (ListE (map tupleE entries)) @@ -89,9 +88,7 @@ ++ show tyName ++ " is not a data/newtype declaration" -{- | @camelCase -> snake_case@. Lowercases the first character then prefixes -@\'_\'@ before every uppercase character (lowercased). --} +-- | Convert @camelCase@ to @snake_case@. camelToSnake :: String -> String camelToSnake [] = [] camelToSnake (c : cs) = toLower c : go cs diff --git a/src/DataFrame/TH/Records.hs b/src/DataFrame/TH/Records.hs --- a/src/DataFrame/TH/Records.hs +++ b/src/DataFrame/TH/Records.hs @@ -4,30 +4,37 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{- | -Module : DataFrame.TH.Records -License : MIT - -Record-based 'DataFrame' splices — the IO-agnostic core of the -'DataFrame.TH' family. Splices that read CSV / Parquet files at compile -time live in @DataFrame.TH.CSV@ (in @dataframe-csv-th@) and -@DataFrame.TH.Parquet@ (in @dataframe-parquet-th@). --} +-- | Record-based 'DataFrame' splices, the IO-agnostic core of 'DataFrame.TH'. module DataFrame.TH.Records ( -- * Declare one binding per column declareColumns, declareColumnsWithPrefix, declareColumnsWithPrefix', + -- * Declare a runtime schema alongside the column bindings + declareSchemaValues, + -- * Type-string parser (exposed for testing) typeFromString, ) where +import qualified Data.Char as Char import Data.Function (on) import Data.Functor ((<&>)) +import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.List as L import qualified Data.Map as M import qualified Data.Text as T +import Data.Time ( + Day, + DiffTime, + LocalTime, + NominalDiffTime, + TimeOfDay, + UTCTime, + ZonedTime, + ) +import Data.Word (Word16, Word32, Word64, Word8) import Control.Monad (forM) import Language.Haskell.TH @@ -41,8 +48,40 @@ unsafeGetColumn, ) import DataFrame.Internal.Expression (Expr) +import DataFrame.Internal.Schema.TH (schemaTypeE) +import DataFrame.Schema (Schema, makeSchema) import Prelude as P +knownTypeNames :: M.Map String Name +knownTypeNames = + M.fromList + [ ("Bool", ''Bool) + , ("Char", ''Char) + , ("Day", ''Day) + , ("DiffTime", ''DiffTime) + , ("Double", ''Double) + , ("Either", ''Either) + , ("Float", ''Float) + , ("Int", ''Int) + , ("Int16", ''Int16) + , ("Int32", ''Int32) + , ("Int64", ''Int64) + , ("Int8", ''Int8) + , ("Integer", ''Integer) + , ("LocalTime", ''LocalTime) + , ("Maybe", ''Maybe) + , ("NominalDiffTime", ''NominalDiffTime) + , ("Ordering", ''Ordering) + , ("TimeOfDay", ''TimeOfDay) + , ("UTCTime", ''UTCTime) + , ("Word", ''Word) + , ("Word16", ''Word16) + , ("Word32", ''Word32) + , ("Word64", ''Word64) + , ("Word8", ''Word8) + , ("ZonedTime", ''ZonedTime) + ] + typeFromString :: [String] -> Q Type typeFromString [] = fail "No type specified" typeFromString [t0] = do @@ -56,7 +95,9 @@ m <- lookupTypeName t case m of Just tyName -> pure (ConT tyName) - Nothing -> fail $ "Unsupported type: " ++ t0 + Nothing -> case M.lookup t knownTypeNames of + Just tyName -> pure (ConT tyName) + Nothing -> fail $ "Unsupported type: " ++ t0 typeFromString [tycon, t1] = AppT <$> typeFromString [tycon] <*> typeFromString [t1] typeFromString [tycon, t1, t2] = (\outer a b -> AppT (AppT outer a) b) @@ -76,10 +117,14 @@ Just (init rest) _ -> Nothing -{- | Splice a binding for every column of @df@, named after the column. -Column names that are not valid Haskell identifiers are sanitized -(see 'DataFrame.Functions.sanitize'). --} +columnSpecs :: DataFrame -> Q [(T.Text, Type)] +columnSpecs df = + let names = (map fst . L.sortBy (compare `on` snd) . M.toList . columnIndices) df + types = map (columnTypeString . (`unsafeGetColumn` df)) names + in forM (zip names types) $ \(colName, tyStr) -> + (,) colName <$> typeFromString (words tyStr) + +-- | Splice a binding for every column of @df@, named after the column. declareColumns :: DataFrame -> DecsQ declareColumns = declareColumnsWithPrefix' Nothing @@ -89,24 +134,65 @@ -- | Like 'declareColumnsWithPrefix' but takes an optional prefix. declareColumnsWithPrefix' :: Maybe T.Text -> DataFrame -> DecsQ -declareColumnsWithPrefix' prefix df = - let - names = (map fst . L.sortBy (compare `on` snd) . M.toList . columnIndices) df - types = map (columnTypeString . (`unsafeGetColumn` df)) names - specs = - zipWith - ( \colName type_ -> - ( colName - , maybe "" (sanitize . (<> "_")) prefix <> sanitize colName - , type_ - ) - ) - names - types - in - fmap concat $ forM specs $ \(raw, nm, tyStr) -> do - ty <- typeFromString (words tyStr) - let n = mkName (T.unpack nm) - sig <- sigD n [t|Expr $(pure ty)|] - val <- valD (varP n) (normalB [|col $(TH.lift raw)|]) [] - pure [sig, val] +declareColumnsWithPrefix' prefix df = do + specs <- columnSpecs df + fmap concat $ forM specs $ \(raw, ty) -> do + let nm = maybe "" (sanitize . (<> "_")) prefix <> sanitize raw + n = mkName (T.unpack nm) + sig <- sigD n [t|Expr $(pure ty)|] + val <- valD (varP n) (normalB [|col $(TH.lift raw)|]) [] + pure [sig, val] + +-- | Splice a runtime 'Schema' for @df@ along with per-column 'Expr' refs. +declareSchemaValues :: String -> DataFrame -> DecsQ +declareSchemaValues prefix df = do + validatePrefix prefix + specs <- columnSpecs df + let n = mkName (prefix ++ "Schema") + entry (raw, ty) = + TupE + [ Just (AppE (VarE 'T.pack) (LitE (StringL (T.unpack raw)))) + , Just (schemaTypeE ty) + ] + sig <- sigD n [t|Schema|] + val <- + valD + (varP n) + (normalB (pure (AppE (VarE 'makeSchema) (ListE (map entry specs))))) + [] + accessors <- fmap concat $ forM specs $ \(raw, ty) -> do + let an = mkName (accessorName prefix raw) + asig <- sigD an [t|Expr $(pure ty)|] + aval <- valD (varP an) (normalB [|col $(TH.lift raw)|]) [] + pure [asig, aval] + pure (sig : val : accessors) + +validatePrefix :: String -> Q () +validatePrefix prefix = case prefix of + (c : _) | Char.isLower c || c == '_' -> pure () + _ -> + fail $ + "declareSchemaValues: prefix " + ++ show prefix + ++ " must start with a lowercase letter or underscore" + +accessorName :: String -> T.Text -> String +accessorName prefix raw = + prefix ++ upperFirst (camelCase (T.unpack (sanitize raw))) + +camelCase :: String -> String +camelCase s = case P.filter (P.not . P.null) (splitOn '_' s) of + [] -> s + (w : ws) -> w ++ P.concatMap upperFirst ws + +splitOn :: Char -> String -> [String] +splitOn c = P.foldr step [[]] + where + step _ [] = [] + step x acc@(cur : rest) + | x == c = [] : acc + | otherwise = (x : cur) : rest + +upperFirst :: String -> String +upperFirst [] = [] +upperFirst (c : cs) = Char.toUpper c : cs diff --git a/src/DataFrame/Typed/TH/Records.hs b/src/DataFrame/Typed/TH/Records.hs --- a/src/DataFrame/Typed/TH/Records.hs +++ b/src/DataFrame/Typed/TH/Records.hs @@ -4,14 +4,7 @@ {-# 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@). --} +-- | Record-based typed-API schema derivation, the IO-agnostic core. module DataFrame.Typed.TH.Records ( -- * Schema inference from an existing DataFrame value deriveSchema, @@ -46,17 +39,14 @@ import DataFrame.Typed.Record ( HasSchema, Schema, - fromColumns, + recordsFromFrame, + recordsToColumns, 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@. --} +-- | Derive an untyped 'Schema' value and per-column accessors from a record. deriveSchemaValues :: Name -> DecsQ deriveSchemaValues = SchemaTH.deriveSchema @@ -115,13 +105,11 @@ -- | Options controlling 'deriveSchemaFromTypeWith'. data SchemaOptions = SchemaOptions { nameTransform :: String -> String - -- ^ Map each record selector name to a column name. Default: 'camelToSnake'. + -- ^ Map each selector name to a column name. Default: 'camelToSnake'. , schemaTypeName :: Maybe String - -- ^ Override the generated type synonym name. Default: @\Schema@. + -- ^ Override the generated type name. Default: @\Schema@. , generateInstance :: Bool - {- ^ When @True@ (default), also generate a 'HasSchema' instance so the - record can be turned into a 'DataFrame' via 'fromRecords' / 'toRecords'. - -} + -- ^ When @True@ (default), also generate a 'HasSchema' instance. } defaultSchemaOptions :: SchemaOptions @@ -211,8 +199,8 @@ [] instType [ schemaInst - , FunD 'toColumns [toClause] - , FunD 'fromColumns [fromClause] + , FunD 'recordsToColumns [toClause] + , FunD 'recordsFromFrame [fromClause] ] mkToColumnsClause :: [(String, Name, Type)] -> Q Clause