{-# LANGUAGE CPP, DataKinds, GADTs, KindSignatures, OverloadedStrings,
             QuasiQuotes, RecordWildCards, RoleAnnotations,
             ScopedTypeVariables, TemplateHaskell, TupleSections,
             TypeApplications, TypeOperators #-}
-- | Code generation of types relevant to Frames use-cases. Generation
-- may be driven by an automated inference process or manual use of
-- the individual helpers.
module Frames.TH where
import Control.Arrow (second)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup ((<>))
#endif
import Data.Proxy (Proxy(..))
import qualified Data.Text as T
import Data.Vinyl
import Data.Vinyl.TypeLevel (RIndex)
import Frames.Col ((:->))
import Frames.ColumnTypeable
import Frames.ColumnUniverse
import Frames.CSV
import Frames.Rec(Record)
import Frames.Utils
import qualified GHC.Types as GHC
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Pipes as P
import qualified Pipes.Prelude as P
import qualified Pipes.Safe as P

-- | Generate a column type.
recDec :: [Type] -> Type
recDec :: [Type] -> Type
recDec = Type -> Type -> Type
AppT (Name -> Type
ConT ''Record) (Type -> Type) -> ([Type] -> Type) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Type
go
  where go :: [Type] -> Type
go [] = Type
PromotedNilT
        go (Type
t:[Type]
cs) = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
PromotedConsT Type
t) ([Type] -> Type
go [Type]
cs)

-- | Declare a type synonym for a column.
mkColSynDec :: TypeQ -> Name -> DecQ
mkColSynDec :: TypeQ -> Name -> DecQ
mkColSynDec TypeQ
colTypeQ Name
colTName = Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
colTName [] TypeQ
colTypeQ

-- | Declare lenses for working with a column.
mkColLensDec :: Name -> Type -> T.Text -> DecsQ
mkColLensDec :: Name -> Type -> Text -> DecsQ
mkColLensDec Name
colTName Type
colTy Text
colPName = [DecQ] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [DecQ
tySig, DecQ
val, DecQ
tySig', DecQ
val']
  where nm :: Name
nm = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
colPName
        nm' :: Name
nm' = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
colPName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
        -- tySig = sigD nm [t|Proxy $(conT colTName)|]
        tySig :: DecQ
tySig = Name -> TypeQ -> DecQ
sigD Name
nm [t|forall f rs.
                           (Functor f,
                            RElem $(conT colTName) rs (RIndex $(conT colTName) rs))
                         => ($(pure colTy) -> f $(pure colTy))
                         -> Record rs
                         -> f (Record rs)
                         |]
        tySig' :: DecQ
tySig' = Name -> TypeQ -> DecQ
sigD Name
nm' [t|forall f g rs.
                            (Functor f,
                             RElem $(conT colTName) rs (RIndex $(conT colTName) rs))
                          => (g $(conT colTName) -> f (g $(conT colTName)))
                          -> Rec g rs
                          -> f (Rec g rs)
                          |]
        val :: DecQ
val = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
nm)
                   (ExpQ -> BodyQ
normalB [e|rlens @($(conT colTName)) . rfield |])
                   []
        val' :: DecQ
val' = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
nm')
                    (ExpQ -> BodyQ
normalB [e|rlens' @($(conT colTName))|])
                    []

lowerHead :: T.Text -> Maybe T.Text
lowerHead :: Text -> Maybe Text
lowerHead = ((Char, Text) -> Text) -> Maybe (Char, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char, Text) -> Text
aux (Maybe (Char, Text) -> Maybe Text)
-> (Text -> Maybe (Char, Text)) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons
  where aux :: (Char, Text) -> Text
aux (Char
c,Text
t) = Char -> Text -> Text
T.cons (Char -> Char
toLower Char
c) Text
t

-- | For each column, we declare a type synonym for its type, and a
-- Proxy value of that type.
colDec :: T.Text -> String -> T.Text
       -> (Either (String -> Q [Dec]) Type)
       -> Q (Type, [Dec])
colDec :: Text
-> String
-> Text
-> Either (String -> DecsQ) Type
-> Q (Type, [Dec])
colDec Text
prefix String
rowName Text
colName Either (String -> DecsQ) Type
colTypeGen = do
  (Type
colTy, [Dec]
extraDecs) <- ((String -> DecsQ) -> Q (Type, [Dec]))
-> (Type -> Q (Type, [Dec]))
-> Either (String -> DecsQ) Type
-> Q (Type, [Dec])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> DecsQ) -> Q (Type, [Dec])
colDecsHelper ((Type, [Dec]) -> Q (Type, [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Type, [Dec]) -> Q (Type, [Dec]))
-> (Type -> (Type, [Dec])) -> Type -> Q (Type, [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[])) Either (String -> DecsQ) Type
colTypeGen
  let colTypeQ :: TypeQ
colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $(return colTy)|]
  Dec
syn <- TypeQ -> Name -> DecQ
mkColSynDec TypeQ
colTypeQ Name
colTName'
  [Dec]
lenses <- Name -> Type -> Text -> DecsQ
mkColLensDec Name
colTName' Type
colTy Text
colPName
  (Type, [Dec]) -> Q (Type, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
colTName', Dec
syn Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
extraDecs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
lenses)
  where colTName :: Text
colTName = Text -> Text
sanitizeTypeName (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize1 Text
colName)
        colPName :: Text
colPName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"colDec impossible" (Text -> Maybe Text
lowerHead Text
colTName)
        colTName' :: Name
colTName' = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
colTName
        colDecsHelper :: (String -> DecsQ) -> Q (Type, [Dec])
colDecsHelper String -> DecsQ
f =
          let qualName :: String
qualName = String
rowName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Text -> Text
capitalize1 Text
colName)
          in (Name -> Type
ConT (String -> Name
mkName String
qualName),) ([Dec] -> (Type, [Dec])) -> DecsQ -> Q (Type, [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> DecsQ
f String
qualName

-- | Splice for manually declaring a column of a given type. For
-- example, @declareColumn "x2" ''Double@ will declare a type synonym
-- @type X2 = "x2" :-> Double@ and a lens @x2@.
declareColumn :: T.Text -> Name -> DecsQ
declareColumn :: Text -> Name -> DecsQ
declareColumn = (Text -> Text -> Name -> DecsQ) -> Text -> Text -> Name -> DecsQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Name -> DecsQ
declarePrefixedColumn Text
T.empty

-- | Splice for manually declaring a column of a given type in which
-- the generated type synonym's name has a prefix applied to the
-- column name. For example, @declarePrefixedColumn "x2" "my"
-- ''Double@ will declare a type synonym @type MyX2 = "x2" :-> Double@
-- and a lens @myX2@.
declarePrefixedColumn :: T.Text -> T.Text -> Name -> DecsQ
declarePrefixedColumn :: Text -> Text -> Name -> DecsQ
declarePrefixedColumn Text
colName Text
prefix Name
colTypeName =
  (:) (Dec -> [Dec] -> [Dec]) -> DecQ -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> Name -> DecQ
mkColSynDec TypeQ
colTypeQ Name
colTName'
      Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Type -> Text -> DecsQ
mkColLensDec Name
colTName' Type
colTy Text
colPName
  where prefix' :: Text
prefix' = Text -> Text
capitalize1 Text
prefix
        colTName :: Text
colTName = Text -> Text
sanitizeTypeName (Text
prefix' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize1 Text
colName)
        colPName :: Text
colPName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"colDec impossible" (Text -> Maybe Text
lowerHead Text
colTName)
        colTName' :: Name
colTName' = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
colTName
        colTy :: Type
colTy = Name -> Type
ConT Name
colTypeName
        colTypeQ :: TypeQ
colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $(return colTy)|]

-- * Default CSV Parsing

-- | Control how row and named column types are generated. The type
-- argument is a type-level list of the possible column types.
data RowGen (a :: [GHC.Type]) =
  RowGen { RowGen a -> [String]
columnNames    :: [String]
           -- ^ Use these column names. If empty, expect a
           -- header row in the data file to provide
           -- column names.
         , RowGen a -> String
tablePrefix    :: String
           -- ^ A common prefix to use for every generated
           -- declaration.
         , RowGen a -> Text
separator      :: Separator
           -- ^ The string that separates the columns on a
           -- row.
         , RowGen a -> String
rowTypeName    :: String
           -- ^ The row type that enumerates all
           -- columns.
         , RowGen a -> Proxy a
columnUniverse :: Proxy a
           -- ^ A record field that mentions the phantom type list of
           -- possible column types. Having this field prevents record
           -- update syntax from losing track of the type argument.
         , RowGen a -> Text -> Producer [Text] (SafeT IO) ()
lineReader :: Separator -> P.Producer [T.Text] (P.SafeT IO) ()
           -- ^ A producer of rows of ’T.Text’ values that were
           -- separated by a 'Separator' value.
         }

-- -- | Shorthand for a 'Proxy' value of 'ColumnUniverse' applied to the
-- -- given type list.
-- colQ :: Name -> Q Exp
-- colQ n = [e| (Proxy :: Proxy (ColumnUniverse $(conT n))) |]

-- | A default 'RowGen'. This instructs the type inference engine to
-- get column names from the data file, use the default column
-- separator (a comma), infer column types from the default 'Columns'
-- set of types, and produce a row type with name @Row@.
rowGen :: FilePath -> RowGen CommonColumns
rowGen :: String -> RowGen CommonColumns
rowGen = [String]
-> String
-> Text
-> String
-> Proxy CommonColumns
-> (Text -> Producer [Text] (SafeT IO) ())
-> RowGen CommonColumns
forall (a :: [*]).
[String]
-> String
-> Text
-> String
-> Proxy a
-> (Text -> Producer [Text] (SafeT IO) ())
-> RowGen a
RowGen [] String
"" Text
defaultSep String
"Row" Proxy CommonColumns
forall k (t :: k). Proxy t
Proxy ((Text -> Producer [Text] (SafeT IO) ()) -> RowGen CommonColumns)
-> (String -> Text -> Producer [Text] (SafeT IO) ())
-> String
-> RowGen CommonColumns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Producer [Text] (SafeT IO) ()
forall (m :: * -> *).
MonadSafe m =>
String -> Text -> Producer [Text] m ()
produceTokens

-- | Like 'rowGen', but will also generate custom data types for
-- 'Categorical' variables with up to 8 distinct variants.
rowGenCat :: FilePath -> RowGen CommonColumnsCat
rowGenCat :: String -> RowGen CommonColumnsCat
rowGenCat = [String]
-> String
-> Text
-> String
-> Proxy CommonColumnsCat
-> (Text -> Producer [Text] (SafeT IO) ())
-> RowGen CommonColumnsCat
forall (a :: [*]).
[String]
-> String
-> Text
-> String
-> Proxy a
-> (Text -> Producer [Text] (SafeT IO) ())
-> RowGen a
RowGen [] String
"" Text
defaultSep String
"Row" Proxy CommonColumnsCat
forall k (t :: k). Proxy t
Proxy ((Text -> Producer [Text] (SafeT IO) ())
 -> RowGen CommonColumnsCat)
-> (String -> Text -> Producer [Text] (SafeT IO) ())
-> String
-> RowGen CommonColumnsCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Producer [Text] (SafeT IO) ()
forall (m :: * -> *).
MonadSafe m =>
String -> Text -> Producer [Text] m ()
produceTokens

-- -- | Generate a type for each row of a table. This will be something
-- -- like @Record ["x" :-> a, "y" :-> b, "z" :-> c]@.
-- tableType :: String -> FilePath -> DecsQ
-- tableType n fp = tableType' (rowGen fp) { rowTypeName = n }

-- | Like 'tableType', but additionally generates a type synonym for
-- each column, and a proxy value of that type. If the CSV file has
-- column names \"foo\", \"bar\", and \"baz\", then this will declare
-- @type Foo = "foo" :-> Int@, for example, @foo = rlens \@Foo@, and
-- @foo' = rlens' \@Foo@.
tableTypes :: String -> FilePath -> DecsQ
tableTypes :: String -> String -> DecsQ
tableTypes String
n String
fp = RowGen CommonColumns -> DecsQ
forall (a :: [*]) c.
(c ~ CoRec ColInfo a, ColumnTypeable c, Monoid c) =>
RowGen a -> DecsQ
tableTypes' (String -> RowGen CommonColumns
rowGen String
fp) { rowTypeName :: String
rowTypeName = String
n }

-- * Customized Data Set Parsing

-- | Inspect no more than this many lines when inferring column types.
prefixSize :: Int
prefixSize :: Int
prefixSize = Int
1000

-- | Generate a type for a row of a table. This will be something like
-- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@.  Column type synonyms
-- are /not/ generated (see 'tableTypes'').
-- tableType' :: forall a. (ColumnTypeable a, Monoid a)
--            => RowGen a -> DecsQ
-- tableType' (RowGen {..}) =
--     pure . TySynD (mkName rowTypeName) [] <$>
--     (runIO (P.runSafeT (readColHeaders opts lineSource)) >>= recDec')
--   where recDec' = recDec . map (second colType) :: [(T.Text, a)] -> Q Type
--         colNames' | null columnNames = Nothing
--                   | otherwise = Just (map T.pack columnNames)
--         opts = ParserOptions colNames' separator (RFC4180Quoting '\"')
--         lineSource = lineReader separator >-> P.take prefixSize

-- | Tokenize the first line of a ’P.Producer’.
colNamesP :: Monad m => P.Producer [T.Text] m () -> m [T.Text]
colNamesP :: Producer [Text] m () -> m [Text]
colNamesP Producer [Text] m ()
src = (() -> [Text])
-> (([Text], Producer [Text] m ()) -> [Text])
-> Either () ([Text], Producer [Text] m ())
-> [Text]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> () -> [Text]
forall a b. a -> b -> a
const []) ([Text], Producer [Text] m ()) -> [Text]
forall a b. (a, b) -> a
fst (Either () ([Text], Producer [Text] m ()) -> [Text])
-> m (Either () ([Text], Producer [Text] m ())) -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Producer [Text] m ()
-> m (Either () ([Text], Producer [Text] m ()))
forall (m :: * -> *) a r.
Monad m =>
Producer a m r -> m (Either r (a, Producer a m r))
P.next Producer [Text] m ()
src

-- | Generate a type for a row of a table all of whose columns remain
-- unparsed 'Text' values.
tableTypesText' :: forall a c.
                   (c ~ CoRec ColInfo a, ColumnTypeable c, Monoid c)
                => RowGen a -> DecsQ
tableTypesText' :: RowGen a -> DecsQ
tableTypesText' (RowGen {String
[String]
Proxy a
Text
Text -> Producer [Text] (SafeT IO) ()
lineReader :: Text -> Producer [Text] (SafeT IO) ()
columnUniverse :: Proxy a
rowTypeName :: String
separator :: Text
tablePrefix :: String
columnNames :: [String]
lineReader :: forall (a :: [*]).
RowGen a -> Text -> Producer [Text] (SafeT IO) ()
columnUniverse :: forall (a :: [*]). RowGen a -> Proxy a
rowTypeName :: forall (a :: [*]). RowGen a -> String
separator :: forall (a :: [*]). RowGen a -> Text
tablePrefix :: forall (a :: [*]). RowGen a -> String
columnNames :: forall (a :: [*]). RowGen a -> [String]
..}) =
  do [Text]
colNames <- IO [Text] -> Q [Text]
forall a. IO a -> Q a
runIO (IO [Text] -> Q [Text])
-> (SafeT IO [Text] -> IO [Text]) -> SafeT IO [Text] -> Q [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeT IO [Text] -> IO [Text]
forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
SafeT m r -> m r
P.runSafeT (SafeT IO [Text] -> Q [Text]) -> SafeT IO [Text] -> Q [Text]
forall a b. (a -> b) -> a -> b
$
                 SafeT IO [Text]
-> ([Text] -> SafeT IO [Text]) -> Maybe [Text] -> SafeT IO [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Producer [Text] (SafeT IO) () -> SafeT IO [Text]
forall (m :: * -> *). Monad m => Producer [Text] m () -> m [Text]
colNamesP (Text -> Producer [Text] (SafeT IO) ()
lineReader Text
separator))
                       [Text] -> SafeT IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                       (ParserOptions -> Maybe [Text]
headerOverride ParserOptions
opts)
     let headers :: [(Text, Type)]
headers = [Text] -> [Type] -> [(Text, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
colNames (Type -> [Type]
forall a. a -> [a]
repeat (Name -> Type
ConT ''T.Text))
     ([Type]
colTypes, [Dec]
colDecs) <- (([[Dec]] -> [Dec]) -> ([Type], [[Dec]]) -> ([Type], [Dec])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Type], [[Dec]]) -> ([Type], [Dec]))
-> ([(Type, [Dec])] -> ([Type], [[Dec]]))
-> [(Type, [Dec])]
-> ([Type], [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Type, [Dec])] -> ([Type], [[Dec]])
forall a b. [(a, b)] -> ([a], [b])
unzip)
                            ([(Type, [Dec])] -> ([Type], [Dec]))
-> Q [(Type, [Dec])] -> Q ([Type], [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Type) -> Q (Type, [Dec]))
-> [(Text, Type)] -> Q [(Type, [Dec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Text -> Type -> Q (Type, [Dec]))
-> (Text, Type) -> Q (Type, [Dec])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Type -> Q (Type, [Dec])
mkColDecs) [(Text, Type)]
headers
     let recTy :: Dec
recTy = Name -> [TyVarBndr] -> Type -> Dec
TySynD (String -> Name
mkName String
rowTypeName) [] ([Type] -> Type
recDec [Type]
colTypes)
         optsName :: Name
optsName = case String
rowTypeName of
                      [] -> String -> Name
forall a. HasCallStack => String -> a
error String
"Row type name shouldn't be empty"
                      Char
h:String
t -> String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Parser"
     Dec
optsTy <- Name -> TypeQ -> DecQ
sigD Name
optsName [t|ParserOptions|]
     Dec
optsDec <- PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
optsName) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ParserOptions -> ExpQ
forall t. Lift t => t -> ExpQ
lift ParserOptions
opts) []

     [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
recTy Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
optsTy Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
optsDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
colDecs)
  where colNames' :: Maybe [Text]
colNames' | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
columnNames = Maybe [Text]
forall a. Maybe a
Nothing
                  | Bool
otherwise = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
columnNames)
        opts :: ParserOptions
opts = Maybe [Text] -> Text -> QuotingMode -> ParserOptions
ParserOptions Maybe [Text]
colNames' Text
separator (Char -> QuotingMode
RFC4180Quoting Char
'\"')
        mkColDecs :: Text -> Type -> Q (Type, [Dec])
mkColDecs Text
colNm Type
colTy = do
          let safeName :: String
safeName = Text -> String
T.unpack (Text -> Text
sanitizeTypeName Text
colNm)
          Maybe Name
mColNm <- String -> Q (Maybe Name)
lookupTypeName (String
tablePrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
safeName)
          case Maybe Name
mColNm of
            Just Name
n -> (Type, [Dec]) -> Q (Type, [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
n, [])
            Maybe Name
Nothing -> Text
-> String
-> Text
-> Either (String -> DecsQ) Type
-> Q (Type, [Dec])
colDec (String -> Text
T.pack String
tablePrefix) String
rowTypeName Text
colNm (Type -> Either (String -> DecsQ) Type
forall a b. b -> Either a b
Right Type
colTy)

-- | Generate a type for a row of a table. This will be something like
-- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@. Additionally generates
-- a type synonym for each column, and a proxy value of that type. If
-- the CSV file has column names \"foo\", \"bar\", and \"baz\", then
-- this will declare @type Foo = "foo" :-> Int@, for example, @foo =
-- rlens \@Foo@, and @foo' = rlens' \@Foo@.
tableTypes' :: forall a c. (c ~ CoRec ColInfo a, ColumnTypeable c, Monoid c)
            => RowGen a -> DecsQ
tableTypes' :: RowGen a -> DecsQ
tableTypes' (RowGen {String
[String]
Proxy a
Text
Text -> Producer [Text] (SafeT IO) ()
lineReader :: Text -> Producer [Text] (SafeT IO) ()
columnUniverse :: Proxy a
rowTypeName :: String
separator :: Text
tablePrefix :: String
columnNames :: [String]
lineReader :: forall (a :: [*]).
RowGen a -> Text -> Producer [Text] (SafeT IO) ()
columnUniverse :: forall (a :: [*]). RowGen a -> Proxy a
rowTypeName :: forall (a :: [*]). RowGen a -> String
separator :: forall (a :: [*]). RowGen a -> Text
tablePrefix :: forall (a :: [*]). RowGen a -> String
columnNames :: forall (a :: [*]). RowGen a -> [String]
..}) =
  do [(Text, c)]
headers <- IO [(Text, c)] -> Q [(Text, c)]
forall a. IO a -> Q a
runIO (IO [(Text, c)] -> Q [(Text, c)])
-> (SafeT IO [(Text, c)] -> IO [(Text, c)])
-> SafeT IO [(Text, c)]
-> Q [(Text, c)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeT IO [(Text, c)] -> IO [(Text, c)]
forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
SafeT m r -> m r
P.runSafeT
                (SafeT IO [(Text, c)] -> Q [(Text, c)])
-> SafeT IO [(Text, c)] -> Q [(Text, c)]
forall a b. (a -> b) -> a -> b
$ ParserOptions
-> Producer [Text] (SafeT IO) () -> SafeT IO [(Text, c)]
forall a (m :: * -> *).
(ColumnTypeable a, Monoid a, Monad m) =>
ParserOptions -> Producer [Text] m () -> m [(Text, a)]
readColHeaders ParserOptions
opts Producer [Text] (SafeT IO) ()
lineSource :: Q [(T.Text, c)]
     ([Type]
colTypes, [Dec]
colDecs) <- (([[Dec]] -> [Dec]) -> ([Type], [[Dec]]) -> ([Type], [Dec])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Type], [[Dec]]) -> ([Type], [Dec]))
-> ([(Type, [Dec])] -> ([Type], [[Dec]]))
-> [(Type, [Dec])]
-> ([Type], [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Type, [Dec])] -> ([Type], [[Dec]])
forall a b. [(a, b)] -> ([a], [b])
unzip)
                            ([(Type, [Dec])] -> ([Type], [Dec]))
-> Q [(Type, [Dec])] -> Q ([Type], [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Either (String -> DecsQ) Type) -> Q (Type, [Dec]))
-> [(Text, Either (String -> DecsQ) Type)] -> Q [(Type, [Dec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Text -> Either (String -> DecsQ) Type -> Q (Type, [Dec]))
-> (Text, Either (String -> DecsQ) Type) -> Q (Type, [Dec])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Either (String -> DecsQ) Type -> Q (Type, [Dec])
mkColDecs)
                                     (((Text, c) -> (Text, Either (String -> DecsQ) Type))
-> [(Text, c)] -> [(Text, Either (String -> DecsQ) Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((CoRec ColInfo a -> Either (String -> DecsQ) Type)
-> (Text, CoRec ColInfo a) -> (Text, Either (String -> DecsQ) Type)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second CoRec ColInfo a -> Either (String -> DecsQ) Type
forall a. ColumnTypeable a => a -> Either (String -> DecsQ) Type
colType) [(Text, c)]
headers)
     let recTy :: Dec
recTy = Name -> [TyVarBndr] -> Type -> Dec
TySynD (String -> Name
mkName String
rowTypeName) [] ([Type] -> Type
recDec [Type]
colTypes)
         optsName :: Name
optsName = case String
rowTypeName of
                      [] -> String -> Name
forall a. HasCallStack => String -> a
error String
"Row type name shouldn't be empty"
                      Char
h:String
t -> String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Parser"
     Dec
optsTy <- Name -> TypeQ -> DecQ
sigD Name
optsName [t|ParserOptions|]
     Dec
optsDec <- PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
optsName) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ParserOptions -> ExpQ
forall t. Lift t => t -> ExpQ
lift ParserOptions
opts) []
     [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec
recTy Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
optsTy Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
optsDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
colDecs)
     -- (:) <$> (tySynD (mkName n) [] (recDec' headers))
     --     <*> (concat <$> mapM (uncurry $ colDec (T.pack prefix)) headers)
  where colNames' :: Maybe [Text]
colNames' | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
columnNames = Maybe [Text]
forall a. Maybe a
Nothing
                  | Bool
otherwise = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
columnNames)
        opts :: ParserOptions
opts = Maybe [Text] -> Text -> QuotingMode -> ParserOptions
ParserOptions Maybe [Text]
colNames' Text
separator (Char -> QuotingMode
RFC4180Quoting Char
'\"')
        lineSource :: Producer [Text] (SafeT IO) ()
lineSource = Text -> Producer [Text] (SafeT IO) ()
lineReader Text
separator Producer [Text] (SafeT IO) ()
-> Proxy () [Text] () [Text] (SafeT IO) ()
-> Producer [Text] (SafeT IO) ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
P.>-> Int -> Proxy () [Text] () [Text] (SafeT IO) ()
forall (m :: * -> *) a. Functor m => Int -> Pipe a a m ()
P.take Int
prefixSize
        mkColDecs :: T.Text -> Either (String -> Q [Dec]) Type -> Q (Type, [Dec])
        mkColDecs :: Text -> Either (String -> DecsQ) Type -> Q (Type, [Dec])
mkColDecs Text
colNm Either (String -> DecsQ) Type
colTy = do
          let safeName :: String
safeName = String
tablePrefix String -> String -> String
forall 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
sanitizeTypeName (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
colNm)
          Maybe Name
mColNm <- String -> Q (Maybe Name)
lookupTypeName String
safeName
          case Maybe Name
mColNm of
            Just Name
n -> (Type, [Dec]) -> Q (Type, [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
n, []) -- Column's type was already defined
            Maybe Name
Nothing -> Text
-> String
-> Text
-> Either (String -> DecsQ) Type
-> Q (Type, [Dec])
colDec (String -> Text
T.pack String
tablePrefix) String
rowTypeName Text
colNm Either (String -> DecsQ) Type
colTy