Frames 0.7.3 → 0.7.4

raw patch · 14 files changed

+759/−452 lines, 14 filesdep +timedep +tomlanddep +tzdep −htomldep ~basedep ~bytestringdep ~containersnew-component:exe:timezonesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: time, tomland, tz, validation-selective

Dependencies removed: htoml

Dependency ranges changed: base, bytestring, containers, contravariant, deepseq, discrimination, ghc-prim, hashable, pipes, pipes-safe, primitive, readable, template-haskell, text, transformers, vector, vector-th-unbox

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• Frames.cabal +33/−22
• README.md +14/−0
• benchmarks/InsuranceBench.hs +1/−1
• demo/TimeZones/src/Columns.hs +30/−0
• demo/TimeZones/src/Main.hs +26/−0
• demo/TimeZones/src/TimeIn.hs +43/−0
• src/Frames/CSV.hs +321/−211
• src/Frames/ColumnTypeable.hs +1/−2
• src/Frames/ColumnUniverse.hs +168/−103
• src/Frames/TH.hs +8/−5
• test/DataCSV.hs +50/−48
• test/PrettyTH.hs +3/−2
• test/examples.toml +58/−58

@@ -1,3 +1,6 @@+# 0.7.4+Replace the `htoml` package used in a test with `tomland`.+ # 0.7.2  - Add `writeCSVopts` that accepts options to specify the CSV delimiter.

@@ -1,6 +1,6 @@ name:                Frames-version:             0.7.3-synopsis:            Data frames For working with tabular data files+version:             0.7.4+synopsis:            Data frames for working with tabular data files description:         User-friendly, type safe, runtime efficient tooling for                      working with tabular data deserialized from                      comma-separated values (CSV) files. The type of@@ -30,7 +30,7 @@                      data/left1.csv data/right1.csv data/left_summary.csv                      data/FL2.csv cabal-version:       >=1.10-tested-with:         GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.1 || == 9.2.1+tested-with:         GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.1 || == 9.2.1 || == 9.4.6  source-repository head   type:     git@@ -64,32 +64,32 @@                        TypeOperators, ConstraintKinds, StandaloneDeriving,                        UndecidableInstances, ScopedTypeVariables,                        OverloadedStrings, TypeApplications-  build-depends:       base >=4.10 && <4.17,-                       ghc-prim >=0.3 && <0.9,-                       primitive >= 0.6 && < 0.8,-                       text >= 1.1.1.0,-                       template-haskell,-                       transformers,-                       vector,-                       readable >= 0.3.1,+  build-depends:       base >=4.10 && <4.20,+                       ghc-prim >=0.3 && <0.10,+                       primitive >= 0.6 && < 0.9,+                       text >= 1.1.1.0 && < 2.1,+                       template-haskell >= 2.10 && < 2.20,+                       transformers >= 0.5.6 && < 0.6,+                       vector < 0.14,+                       readable >= 0.3.1 && < 0.4,                        pipes >= 4.1 && < 5,                        pipes-bytestring >= 2.1.6 && < 2.2,                        pipes-group >= 1.0.8 && < 1.1,                        pipes-parse >= 3.0 && < 3.1,                        pipes-safe >= 2.2.6 && < 2.4,-                       bytestring,+                       bytestring < 0.12,                        vinyl >= 0.13.0 && < 0.15,-                       discrimination,-                       contravariant,-                       hashable,-                       deepseq >= 1.4,-                       containers,-                       vector-th-unbox >= 0.2.1.6+                       discrimination >= 0.4 && < 0.6,+                       contravariant < 1.6,+                       hashable >= 1.3 && < 1.5,+                       deepseq >= 1.4 && < 1.5,+                       containers < 0.7,+                       vector-th-unbox >= 0.2.1.6 && < 0.3   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall --- Get the large-ish data files used in the demo and benchmark+-- Get the largeish data files used in the demo and benchmark executable getdata   if !flag(demos)     buildable: False@@ -227,6 +227,17 @@   hs-source-dirs: demo   default-language: Haskell2010 +executable timezones+  if !flag(demos)+    buildable: False+  main-is: Main.hs+  other-modules: TimeIn Columns+  if flag(demos)+    build-depends: base, Frames, tz, text, time, readable,+                   pipes, pipes-safe, template-haskell+  hs-source-dirs: demo/TimeZones/src+  default-language: Haskell2010+ test-suite spec   type:                exitcode-stdio-1.0   hs-source-dirs:      test@@ -235,9 +246,9 @@                        UncurryFold UncurryFoldNoHeader UncurryFoldPartialData                        Categorical Chunks Issue145   build-depends:       base, text, hspec, Frames, template-haskell,-                       temporary, directory, htoml, regex-applicative, pretty,-                       unordered-containers, pipes, HUnit, vinyl,-                       foldl >= 1.3 && < 1.5,+                       temporary, directory, tomland, regex-applicative, pretty,+                       unordered-containers, pipes, HUnit, vinyl, +                       foldl >= 1.3 && < 1.5, validation-selective,                        attoparsec, lens, bytestring   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall   default-language:    Haskell2010

@@ -130,6 +130,20 @@ There are various [demos](https://github.com/acowley/Frames/tree/master/demo) in the repository. Be sure to run the `getdata` build target to download the data files used by the demos! You can also download the data files manually and put them in a `data` directory in the directory from which you will be running the executables.  +## Contribute++You can build Frames via [nix](www.nixos.org) with the following command:+```+nix build .#Frames-8107  # or nix build .#Frames-921+```+this creates an ./result link in the current folder.++To get a development shell with all libraries, you can run:+```+nix develop .#Frames-921+```+To get just ghc and cabal in your shell, a simple `nix develop` will do.+ ## Benchmarks  The [benchmark](https://github.com/acowley/Frames/tree/master/benchmarks/InsuranceBench.hs) shows several ways of dealing with data when you want to perform multiple traversals.

@@ -63,7 +63,7 @@      return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n)  -- | Perform two consecutive folds after projecting a subset of an--- in-memory reprsentation.+-- in-memory representation. pipeBenchAoS :: IO (P Double) pipeBenchAoS = do tbl <- inCoreAoS' rcast tblP :: IO (Frame TinyIns)                   let (n,sumLat) =

@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Define the column types used to represent our data. Here, we wish+-- to parse data captured as 'Data.Time.LocalTime.LocalTime' values+-- into the \"America/Chicago\" time zone.+module Columns (MyColumns, TimeIn(..), Chicago(..)) where+import Data.Proxy (Proxy(..))+import Frames (CommonColumns)+import Frames.ColumnTypeable (Parseable(..))+import Frames.CSV (defaultSep, produceTokens)+import TimeIn++-- | Define a 'Parseable' instance for @TimeIn "America/Chicago"@+timeIn "America/Chicago"++-- | We need this newtype because Template Haskell can not handle the+-- type @TimeIn "America/Chicago"@ as of @GHC-8.0.1@ and+-- @template-haskell-2.11.0.0@+newtype Chicago = Chicago (TimeIn "America/Chicago") deriving Show++instance Parseable Chicago where+  parse = fmap (fmap Chicago) . parse++-- | The column types we expect our data to conform to+type MyColumns = Chicago ': CommonColumns

@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+-- | Parse data including dates times in some implicit local time zone+-- into an absolute time using a supplied time zone.+module Main where+import Data.Proxy (Proxy(Proxy))+import Frames+import Frames.CSV+import Frames.TH (RowGen(columnUniverse), colQ, rowGen)+import Columns+import Pipes (Producer, (>->), runEffect)+import qualified Pipes.Prelude as P+import Pipes.Safe+import Frames (ColumnUniverse)+import Columns (MyColumns)++-- tableTypes' rowGen { columnUniverse = $(colQ ''MyColumns) } "/Users/acowley/Projects/Frames/demo/TimeZones/users.csv"+tableTypes' ((rowGen "demo/TimeZones/users.csv") { columnUniverse = Proxy @MyColumns })++loadUsers :: Producer Row (SafeT IO) ()+loadUsers = readTable "demo/TimeZones/users.csv"++main :: IO ()+main = runSafeEffect $ loadUsers >-> P.print

@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+-- | Define the 'TimeIn' type that lets us specify in the type how a+-- 'LocalTime' should be converted to a 'UTCTime'.+module TimeIn where+import Control.Monad (MonadPlus (mzero), msum)+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime+import Data.Time.Zones+import Data.Time.Zones.TH+import Frames.ColumnTypeable (Parseable(..), Parsed(..))+import GHC.TypeLits+import Language.Haskell.TH++-- | A 'UTCTime' tagged with a symbol denoting the 'TZ' time zone from+-- whence it came.+newtype TimeIn (zone :: Symbol) = TimeIn UTCTime deriving Show++failZero :: MonadPlus m => Maybe r -> m r+failZero = maybe mzero pure++-- | Try to parse a 'LocalTime' value using common formats.+parseLocalTime :: MonadPlus m => T.Text -> m LocalTime+parseLocalTime t = msum (map (($ T.unpack t) . mkParser) formats)+  where formats = ["%F %T", "%F"]+        mkParser = (failZero .) . parseTimeM True defaultTimeLocale++-- | @zonedTime "America/Chicago"@ will create a 'Parseable' instance+-- for the type @TimeIn "America/Chicago"@. You can then use this type+-- when loading data.+timeIn :: String -> DecsQ+timeIn tzStr =+  do let fromLocal = [e| localTimeToUTCTZ $(includeTZFromDB tzStr) |]+         ex = [e| fmap (Definitely . TimeIn . $fromLocal) . parseLocalTime |]+     sequenceA [+       instanceD (pure [])+                 [t|Parseable (TimeIn $(pure $ LitT (StrTyLit tzStr)))|]+                 [ funD (mkName "parse") [clause [] (normalB ex) []] ] ]

@@ -1,19 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE CPP, DataKinds, DeriveLift, FlexibleContexts, FlexibleInstances, GADTs,-             LambdaCase, OverloadedStrings, RankNTypes,-             ScopedTypeVariables, TemplateHaskell, TypeApplications,-             TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+ -- | Infer row types from comma-separated values (CSV) data and read -- that data from files. Template Haskell is used to generate the -- necessary types so that you can write type safe programs referring -- to those types. module Frames.CSV where-import Control.Exception (try, IOException)-import Control.Monad (when, unless)++import Control.Exception (IOException, try)+import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as B8 import qualified Data.Foldable as F import Data.List (intercalate)-import Data.Maybe (isNothing, fromMaybe)+import Data.Maybe (fromMaybe, isNothing) #if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) #endif@@ -21,10 +32,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T-import Data.Vinyl (recordToList, Rec(..), ElField(..), RecordToList)-import Data.Vinyl (RecMapMethod, rmapMethod, RMap, rmap)+import Data.Vinyl (ElField (..), RMap, Rec (..), RecMapMethod, RecordToList, recordToList, rmap, rmapMethod) import Data.Vinyl.Class.Method (PayloadType)-import Data.Vinyl.Functor (Const(..), (:.), Compose(..))+import Data.Vinyl.Functor (Compose (..), Const (..), (:.)) import Frames.Col import Frames.ColumnTypeable import Frames.Rec@@ -35,11 +45,11 @@ import Language.Haskell.TH.Syntax import Pipes ((>->)) import qualified Pipes as P-import qualified Pipes.Prelude as P import qualified Pipes.Parse as P+import qualified Pipes.Prelude as P import qualified Pipes.Safe as P import qualified Pipes.Safe.Prelude as Safe-import System.IO (Handle, IOMode(ReadMode, WriteMode), hPrint, stderr)+import System.IO (Handle, IOMode (ReadMode, WriteMode), hPrint, stderr)  -- * Parsing @@ -48,31 +58,35 @@ type QuoteChar = Char  data QuotingMode-    -- | No quoting enabled. The separator may not appear in values-  = NoQuoting-    -- | Quoted values with the given quoting character. Quotes are escaped by doubling them.-    -- Mostly RFC4180 compliant, except doesn't support newlines in values-  | RFC4180Quoting QuoteChar-  deriving (Eq, Show, Lift)+    = -- | No quoting enabled. The separator may not appear in values+      NoQuoting+    | -- | Quoted values with the given quoting character. Quotes are escaped by doubling them.+      -- Mostly RFC4180 compliant, except doesn't support newlines in values+      RFC4180Quoting QuoteChar+    deriving (Eq, Show, Lift) -data ParserOptions = ParserOptions { headerOverride :: Maybe [T.Text]-                                   , columnSeparator :: Separator-                                   , quotingMode :: QuotingMode }-  deriving (Eq, Show)+data ParserOptions = ParserOptions+    { headerOverride :: Maybe [T.Text]+    , columnSeparator :: Separator+    , quotingMode :: QuotingMode+    }+    deriving (Eq, Show)  instance Lift ParserOptions where-  lift (ParserOptions Nothing sep quoting) = [|ParserOptions Nothing $sep' $quoting'|]-    where sep' = [|T.pack $(stringE $ T.unpack sep)|]-          quoting' = lift quoting-  lift (ParserOptions (Just hs) sep quoting) = [|ParserOptions (Just $hs') $sep' $quoting'|]-    where sep' = [|T.pack $(stringE $ T.unpack sep)|]-          hs' = [|map T.pack $(listE $  map (stringE . T.unpack) hs)|]-          quoting' = lift quoting+    lift (ParserOptions Nothing sep quoting) = [|ParserOptions Nothing $sep' $quoting'|]+      where+        sep' = [|T.pack $(stringE $ T.unpack sep)|]+        quoting' = lift quoting+    lift (ParserOptions (Just hs) sep quoting) = [|ParserOptions (Just $hs') $sep' $quoting'|]+      where+        sep' = [|T.pack $(stringE $ T.unpack sep)|]+        hs' = [|map T.pack $(listE $ map (stringE . T.unpack) hs)|]+        quoting' = lift quoting #if MIN_VERSION_template_haskell(2,16,0) #if MIN_VERSION_template_haskell(2,17,0)-  liftTyped = liftCode . unsafeTExpCoerce . lift+    liftTyped = liftCode . unsafeTExpCoerce . lift #else-  liftTyped = unsafeTExpCoerce . lift+    liftTyped = unsafeTExpCoerce . lift #endif #endif @@ -88,49 +102,51 @@ -- | Helper to split a 'T.Text' on commas and strip leading and -- trailing whitespace from each resulting chunk. tokenizeRow :: ParserOptions -> T.Text -> [T.Text]-tokenizeRow options =-    handleQuoting . T.splitOn sep-  where sep = columnSeparator options-        quoting = quotingMode options-        handleQuoting = case quoting of-          NoQuoting -> id-          RFC4180Quoting quote -> reassembleRFC4180QuotedParts sep quote+tokenizeRow options = handleQuoting . T.splitOn sep+  where+    sep = columnSeparator options+    quoting = quotingMode options+    handleQuoting = case quoting of+        NoQuoting -> id+        RFC4180Quoting quote -> reassembleRFC4180QuotedParts sep quote  -- | Post processing applied to a list of tokens split by the--- separator which should have quoted sections reassembeld+-- separator which should have quoted sections reassembled reassembleRFC4180QuotedParts :: Separator -> QuoteChar -> [T.Text] -> [T.Text] reassembleRFC4180QuotedParts sep quoteChar = go-  where go [] = []-        go (part:parts)-          | T.null part = T.empty : go parts-          | prefixQuoted part =+  where+    go [] = []+    go (part : parts)+        | T.null part = T.empty : go parts+        | prefixQuoted part =             if suffixQuoted part-            then unescape (T.drop 1 . T.dropEnd 1 $ part) : go parts-            else case break suffixQuoted parts of-                   (h,[]) -> [unescape (T.intercalate sep (T.drop 1 part : h))]-                   (h,t:ts) -> unescape-                                 (T.intercalate-                                    sep-                                    (T.drop 1 part : h ++ [T.dropEnd 1 t]))-                               : go ts-          | otherwise = T.strip part : go parts--        prefixQuoted t =-          T.head t == quoteChar--  &&-          -- T.length (T.takeWhile (== quoteChar) t) `rem` 2 == 1--        suffixQuoted t =-          quoteText `T.isSuffixOf` t--  &&-          -- T.length (T.takeWhileEnd (== quoteChar) t) `rem` 2 == 1+                then unescape (T.drop 1 . T.dropEnd 1 $ part) : go parts+                else case break suffixQuoted parts of+                    (h, []) -> [unescape (T.intercalate sep (T.drop 1 part : h))]+                    (h, t : ts) ->+                        unescape+                            ( T.intercalate+                                sep+                                (T.drop 1 part : h ++ [T.dropEnd 1 t])+                            )+                            : go ts+        | otherwise = T.strip part : go parts -        quoteText = T.singleton quoteChar+    prefixQuoted t =+        T.head t == quoteChar --  &&+        -- T.length (T.takeWhile (== quoteChar) t) `rem` 2 == 1+    suffixQuoted t =+        quoteText `T.isSuffixOf` t --  &&+        -- T.length (T.takeWhileEnd (== quoteChar) t) `rem` 2 == 1+    quoteText = T.singleton quoteChar -        unescape :: T.Text -> T.Text-        unescape = T.replace q2 quoteText-          where q2 = quoteText <> quoteText+    unescape :: T.Text -> T.Text+    unescape = T.replace q2 quoteText+      where+        q2 = quoteText <> quoteText ---tokenizeRow :: Separator -> T.Text -> [T.Text]---tokenizeRow sep = map (unquote . T.strip) . T.splitOn sep+-- tokenizeRow :: Separator -> T.Text -> [T.Text]+-- tokenizeRow sep = map (unquote . T.strip) . T.splitOn sep --  where unquote txt --          | quoted txt = case T.dropEnd 1 (T.drop 1 txt) of --                           txt' | T.null txt' -> "Col"@@ -145,143 +161,180 @@  -- | Infer column types from a prefix (up to 1000 lines) of a CSV -- file.-prefixInference :: (ColumnTypeable a, Monoid a, Monad m)-                => P.Parser [T.Text] m [a]-prefixInference = P.draw >>= \case-  Nothing -> return []-  Just row1 -> P.foldAll (\ts -> zipWith (<>) ts . inferCols)-                         (inferCols row1)-                         id-  where inferCols = map inferType+prefixInference ::+    (ColumnTypeable a, Semigroup a, Monad m, Show a) =>+    P.Parser [T.Text] m [a]+prefixInference =+    P.draw >>= \case+        Nothing -> return []+        Just row1 ->+            P.foldAll+                (\ts -> zipWith (<>) ts . inferCols)+                (inferCols row1)+                id+  where+    inferCols = map inferType  -- | Extract column names and inferred types from a CSV file.-readColHeaders :: (ColumnTypeable a, Monoid a, Monad m)-               => ParserOptions -> P.Producer [T.Text] m () -> m [(T.Text, a)]+readColHeaders ::+    (ColumnTypeable a, Semigroup a, Monad m, Show a) =>+    ParserOptions+    -> P.Producer [T.Text] m ()+    -> m [(T.Text, a)] readColHeaders opts = P.evalStateT $-  do headerRow <- maybe (fromMaybe err <$> P.draw)-                        pure-                        (headerOverride opts)-     colTypes <- prefixInference-     unless (length headerRow == length colTypes) (error errNumColumns)-     return (zip headerRow colTypes)-  where err = error "Empty Producer has no header row"-        errNumColumns =-          unlines-          [ ""-          , "Error parsing CSV: "-          , "  Number of columns in header differs from number of columns"-          , "  found in the remaining file. This may be due to newlines"-          , "  being present within the data itself (not just separating"-          , "  rows). If support for embedded newlines is required, "-          , "  consider using the Frames-dsv package in conjunction with"-          , "  Frames to make use of a different CSV parser."]+    do+        headerRow <-+            maybe+                (fromMaybe err <$> P.draw)+                pure+                (headerOverride opts)+        colTypes <- prefixInference+        unless (length headerRow == length colTypes) (error errNumColumns)+        return (zip headerRow colTypes)+  where+    err = error "Empty Producer has no header row"+    errNumColumns =+        unlines+            [ ""+            , "Error parsing CSV: "+            , "  Number of columns in header differs from number of columns"+            , "  found in the remaining file. This may be due to newlines"+            , "  being present within the data itself (not just separating"+            , "  rows). If support for embedded newlines is required, "+            , "  consider using the Frames-dsv package in conjunction with"+            , "  Frames to make use of a different CSV parser."+            ]  -- * Loading CSV Data  -- | Parsing each component of a 'RecF' from a list of text chunks, -- one chunk per record component. class ReadRec rs where-  readRec :: [T.Text] -> Rec (Either T.Text :. ElField) rs+    readRec :: [T.Text] -> Rec (Either T.Text :. ElField) rs  instance ReadRec '[] where-  readRec _ = RNil+    readRec _ = RNil  instance (Parseable t, ReadRec ts, KnownSymbol s) => ReadRec (s :-> t ': ts) where-  readRec [] = Compose (Left mempty) :& readRec []-  readRec (h:t) = maybe (Compose (Left (T.copy h)))-                        (Compose . Right . Field)-                        (parse' h) :& readRec t+    readRec [] = Compose (Left mempty) :& readRec []+    readRec (h : t) =+        maybe+            (Compose (Left (T.copy h)))+            (Compose . Right . Field)+            (parse' h)+            :& readRec t  -- | Opens a file (in 'P.MonadSafe') and repeatedly applies the given -- function to the 'Handle' to obtain lines to yield. Adapted from the -- moribund pipes-text package.-pipeLines :: P.MonadSafe m-          => (Handle -> IO (Either IOException T.Text))-          -> FilePath-          -> P.Producer T.Text m ()+pipeLines ::+    (P.MonadSafe m) =>+    (Handle -> IO (Either IOException T.Text))+    -> FilePath+    -> P.Producer T.Text m () pipeLines pgetLine fp = Safe.withFile fp ReadMode $ \h ->-  let loop = do txt <- P.liftIO (pgetLine h)-                case txt of-                  Left _e -> return ()-                  Right y -> P.yield y >> loop-  in loop+    let loop = do+            txt <- P.liftIO (pgetLine h)+            case txt of+                Left _e -> return ()+                Right y -> P.yield y >> loop+     in loop  -- | Produce lines of 'T.Text'.-produceTextLines :: P.MonadSafe m => FilePath -> P.Producer T.Text m ()+produceTextLines :: (P.MonadSafe m) => FilePath -> P.Producer T.Text m () produceTextLines = pipeLines (try . T.hGetLine)  -- | Produce lines of tokens that were separated by the given -- separator.-produceTokens :: P.MonadSafe m-              => FilePath-              -> Separator-              -> P.Producer [T.Text] m ()+produceTokens ::+    (P.MonadSafe m) =>+    FilePath+    -> Separator+    -> P.Producer [T.Text] m () produceTokens fp sep = produceTextLines fp >-> P.map tokenize-  where tokenize = tokenizeRow popts-        popts = defaultParser { columnSeparator = sep }+  where+    tokenize = tokenizeRow popts+    popts = defaultParser{columnSeparator = sep}  -- | Consume lines of 'T.Text', writing them to a file.-consumeTextLines :: P.MonadSafe m => FilePath -> P.Consumer T.Text m r+consumeTextLines :: (P.MonadSafe m) => FilePath -> P.Consumer T.Text m r consumeTextLines fp = Safe.withFile fp WriteMode $ \h ->-  let loop = P.await >>= P.liftIO . T.hPutStrLn h >> loop-  in loop+    let loop = P.await >>= P.liftIO . T.hPutStrLn h >> loop+     in loop  -- | Produce the lines of a latin1 (or ISO8859 Part 1) encoded file as -- ’T.Text’ values.-readFileLatin1Ln :: P.MonadSafe m => FilePath -> P.Producer [T.Text] m ()-readFileLatin1Ln fp = pipeLines (try . fmap T.decodeLatin1 . B8.hGetLine) fp-                      >-> P.map (tokenizeRow defaultParser)+readFileLatin1Ln :: (P.MonadSafe m) => FilePath -> P.Producer [T.Text] m ()+readFileLatin1Ln fp =+    pipeLines (try . fmap T.decodeLatin1 . B8.hGetLine) fp+        >-> P.map (tokenizeRow defaultParser)  -- | Read a 'RecF' from one line of CSV.-readRow :: ReadRec rs-        => ParserOptions -> T.Text -> Rec (Either T.Text :. ElField) rs+readRow ::+    (ReadRec rs) =>+    ParserOptions+    -> T.Text+    -> Rec (Either T.Text :. ElField) rs readRow = (readRec .) . tokenizeRow  -- | Produce rows where any given entry can fail to parse.-readTableMaybeOpt :: (P.MonadSafe m, ReadRec rs, RMap rs)-                  => ParserOptions-                  -> FilePath-                  -> P.Producer (Rec (Maybe :. ElField) rs) m ()+readTableMaybeOpt ::+    (P.MonadSafe m, ReadRec rs, RMap rs) =>+    ParserOptions+    -> FilePath+    -> P.Producer (Rec (Maybe :. ElField) rs) m () readTableMaybeOpt opts csvFile =-  produceTokens csvFile (columnSeparator opts) >-> pipeTableMaybeOpt opts+    produceTokens csvFile (columnSeparator opts) >-> pipeTableMaybeOpt opts  -- | Stream lines of CSV data into rows of ’Rec’ values values where -- any given entry can fail to parse.-pipeTableMaybeOpt :: (Monad m, ReadRec rs, RMap rs)-                  => ParserOptions-                  -> P.Pipe [T.Text] (Rec (Maybe :. ElField) rs) m ()+pipeTableMaybeOpt ::+    (Monad m, ReadRec rs, RMap rs) =>+    ParserOptions+    -> P.Pipe [T.Text] (Rec (Maybe :. ElField) rs) m () pipeTableMaybeOpt opts = do-  when (isNothing (headerOverride opts)) (() <$ P.await)-  P.map (rmap (either (const (Compose Nothing))-                      (Compose . Just) . getCompose)-         . readRec)+    when (isNothing (headerOverride opts)) (() <$ P.await)+    P.map+        ( rmap+            ( either+                (const (Compose Nothing))+                (Compose . Just)+                . getCompose+            )+            . readRec+        )  -- | Stream lines of CSV data into rows of ’Rec’ values values where -- any given entry can fail to parse. In the case of a parse failure, the -- raw 'T.Text' of that entry is retained.-pipeTableEitherOpt :: (Monad m, ReadRec rs)-                   => ParserOptions-                   -> P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m ()+pipeTableEitherOpt ::+    (Monad m, ReadRec rs) =>+    ParserOptions+    -> P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m () pipeTableEitherOpt opts = do-  when (isNothing (headerOverride opts)) (() <$ P.await)-  P.map (readRow opts)+    when (isNothing (headerOverride opts)) (() <$ P.await)+    P.map (readRow opts)  -- | Produce rows where any given entry can fail to parse.-readTableMaybe :: (P.MonadSafe m, ReadRec rs, RMap rs)-               => FilePath -> P.Producer (Rec (Maybe :. ElField) rs) m ()+readTableMaybe ::+    (P.MonadSafe m, ReadRec rs, RMap rs) =>+    FilePath+    -> P.Producer (Rec (Maybe :. ElField) rs) m () readTableMaybe = readTableMaybeOpt defaultParser  -- | Stream lines of CSV data into rows of ’Rec’ values where any -- given entry can fail to parse.-pipeTableMaybe :: (Monad m, ReadRec rs, RMap rs)-               => P.Pipe [T.Text] (Rec (Maybe :. ElField) rs) m ()+pipeTableMaybe ::+    (Monad m, ReadRec rs, RMap rs) =>+    P.Pipe [T.Text] (Rec (Maybe :. ElField) rs) m () pipeTableMaybe = pipeTableMaybeOpt defaultParser  -- | Stream lines of CSV data into rows of ’Rec’ values where any -- given entry can fail to parse. In the case of a parse failure, the -- raw 'T.Text' of that entry is retained.-pipeTableEither :: (Monad m, ReadRec rs)-                => P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m ()+pipeTableEither ::+    (Monad m, ReadRec rs) =>+    P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m () pipeTableEither = pipeTableEitherOpt defaultParser  -- -- | Returns a `MonadPlus` producer of rows for which each column was@@ -308,113 +361,170 @@  -- | Returns a producer of rows for which each column was successfully -- parsed.-readTableOpt :: (P.MonadSafe m, ReadRec rs, RMap rs)-             => ParserOptions -> FilePath -> P.Producer (Record rs) m ()+readTableOpt ::+    (P.MonadSafe m, ReadRec rs, RMap rs) =>+    ParserOptions+    -> FilePath+    -> P.Producer (Record rs) m () readTableOpt opts csvFile = readTableMaybeOpt opts csvFile P.>-> go-  where go = P.await >>= maybe go (\x -> P.yield x >> go) . recMaybe+  where+    go = P.await >>= maybe go (\x -> P.yield x >> go) . recMaybe  -- | Pipe lines of CSV text into rows for which each column was -- successfully parsed.-pipeTableOpt :: (ReadRec rs, RMap rs, Monad m)-             => ParserOptions -> P.Pipe [T.Text] (Record rs) m ()+pipeTableOpt ::+    (ReadRec rs, RMap rs, Monad m) =>+    ParserOptions+    -> P.Pipe [T.Text] (Record rs) m () pipeTableOpt opts = pipeTableMaybeOpt opts >-> P.map recMaybe >-> P.concat  -- | Returns a producer of rows for which each column was successfully -- parsed.-readTable :: (P.MonadSafe m, ReadRec rs, RMap rs)-          => FilePath -> P.Producer (Record rs) m ()+readTable ::+    (P.MonadSafe m, ReadRec rs, RMap rs) =>+    FilePath+    -> P.Producer (Record rs) m () readTable = readTableOpt defaultParser -readRecEither :: (ReadRec rs, RMap rs)-              => [T.Text] -> Either (Rec (Either T.Text :. ElField) rs) (Record rs)-readRecEither tokens = let tmp = readRec tokens-                       in case rtraverse getCompose tmp of-                            Right r -> Right r-                            _ -> Left tmp+readRecEither ::+    (ReadRec rs, RMap rs) =>+    [T.Text]+    -> Either (Rec (Either T.Text :. ElField) rs) (Record rs)+readRecEither tokens =+    let tmp = readRec tokens+     in case rtraverse getCompose tmp of+            Right r -> Right r+            _ -> Left tmp  -- | Similar to 'readTable' except that rows that fail to parse are -- printed to @stderr@ with columns that failed to parse printed as -- @"Left rawtext"@ while those that were successfully parsed are -- shown as @"Right text"@.-readTableDebug :: forall m rs.-                  (P.MonadSafe m, ReadRec rs, RMap rs,-                   RecMapMethod ShowCSV (Either T.Text :. ElField) rs,-                   RecordToList rs)-               => FilePath -> P.Producer (Record rs) m ()+readTableDebug ::+    forall m rs.+    ( P.MonadSafe m+    , ReadRec rs+    , RMap rs+    , RecMapMethod ShowCSV (Either T.Text :. ElField) rs+    , RecordToList rs+    ) =>+    FilePath+    -> P.Producer (Record rs) m () readTableDebug csvFile =-  produceTokens csvFile (columnSeparator opts) >-> go >-> debugAll-  where opts = defaultParser-        go = do-          when (isNothing (headerOverride opts)) (() <$ P.await)-          P.map readRecEither-        debugAll = do-          P.await >>= either (P.liftIO . hPrint stderr . debugOne) P.yield-          debugAll-        debugOne = recordToList . rmapMethod @ShowCSV (aux . getCompose)-        aux :: (ShowCSV (PayloadType ElField a))-            => Either T.Text (ElField a) -> Const T.Text a-        aux (Right (Field x)) = Const ("Right " <> showCSV x)-        aux (Left txt) = Const ("Left " <> txt)+    produceTokens csvFile (columnSeparator opts) >-> go >-> debugAll+  where+    opts = defaultParser+    go = do+        when (isNothing (headerOverride opts)) (() <$ P.await)+        P.map readRecEither+    debugAll = do+        P.await >>= either (P.liftIO . hPrint stderr . debugOne) P.yield+        debugAll+    debugOne = recordToList . rmapMethod @ShowCSV (aux . getCompose)+    aux ::+        (ShowCSV (PayloadType ElField a)) =>+        Either T.Text (ElField a)+        -> Const T.Text a+    aux (Right (Field x)) = Const ("Right " <> showCSV x)+    aux (Left txt) = Const ("Left " <> txt)  -- | Pipe lines of CSV text into rows for which each column was -- successfully parsed.-pipeTable :: (ReadRec rs, RMap rs, Monad m)-          => P.Pipe [T.Text] (Record rs) m ()+pipeTable ::+    (ReadRec rs, RMap rs, Monad m) =>+    P.Pipe [T.Text] (Record rs) m () pipeTable = pipeTableOpt defaultParser  -- * Writing CSV Data -showFieldsCSV :: (RecMapMethod ShowCSV ElField ts, RecordToList ts)-              => Record ts -> [T.Text]+showFieldsCSV ::+    (RecMapMethod ShowCSV ElField ts, RecordToList ts) =>+    Record ts+    -> [T.Text] showFieldsCSV = recordToList . rmapMethod @ShowCSV aux-  where aux :: (ShowCSV (PayloadType ElField a))-            => ElField a -> Const T.Text a-        aux (Field x) = Const (showCSV x)+  where+    aux ::+        (ShowCSV (PayloadType ElField a)) =>+        ElField a+        -> Const T.Text a+    aux (Field x) = Const (showCSV x)  -- | 'P.yield' a header row with column names followed by a line of -- text for each 'Record' with each field separated by a comma. If -- your source of 'Record' values is a 'P.Producer', consider using -- 'pipeToCSV' to keep everything streaming.-produceCSV :: forall f ts m.-              (ColumnHeaders ts, Foldable f, Monad m, RecordToList ts,-              RecMapMethod ShowCSV ElField ts)-           => f (Record ts) -> P.Producer String m ()+produceCSV ::+    forall f ts m.+    ( ColumnHeaders ts+    , Foldable f+    , Monad m+    , RecordToList ts+    , RecMapMethod ShowCSV ElField ts+    ) =>+    f (Record ts)+    -> P.Producer String m () produceCSV = produceDSV defaultParser -produceDSV :: forall f ts m.-              (ColumnHeaders ts, Foldable f, Monad m, RecordToList ts,-              RecMapMethod ShowCSV ElField ts)-           => ParserOptions -> f (Record ts) -> P.Producer String m ()+produceDSV ::+    forall f ts m.+    ( ColumnHeaders ts+    , Foldable f+    , Monad m+    , RecordToList ts+    , RecMapMethod ShowCSV ElField ts+    ) =>+    ParserOptions+    -> f (Record ts)+    -> P.Producer String m () produceDSV opts recs = do-  P.yield (intercalate (T.unpack separator) (columnHeaders (Proxy :: Proxy (Record ts))))-  F.mapM_ (P.yield . T.unpack . T.intercalate separator . showFieldsCSV) recs+    P.yield (intercalate (T.unpack separator) (columnHeaders (Proxy :: Proxy (Record ts))))+    F.mapM_ (P.yield . T.unpack . T.intercalate separator . showFieldsCSV) recs   where     separator = columnSeparator opts  -- | 'P.yield' a header row with column names followed by a line of -- text for each 'Record' with each field separated by a comma. This--- is the same as 'produceCSV', but adapated for cases where you have+-- is the same as 'produceCSV', but adapted for cases where you have -- streaming input that you wish to use to produce streaming output.-pipeToCSV :: forall ts m.-             (Monad m, ColumnHeaders ts, RecordToList ts,-              RecMapMethod ShowCSV ElField ts)-          => P.Pipe (Record ts) T.Text m ()+pipeToCSV ::+    forall ts m.+    ( Monad m+    , ColumnHeaders ts+    , RecordToList ts+    , RecMapMethod ShowCSV ElField ts+    ) =>+    P.Pipe (Record ts) T.Text m () pipeToCSV = P.yield (T.intercalate "," (map T.pack header)) >> go-  where header = columnHeaders (Proxy :: Proxy (Record ts))-        go :: P.Pipe (Record ts) T.Text m ()-        go = P.map (T.intercalate "," . showFieldsCSV)+  where+    header = columnHeaders (Proxy :: Proxy (Record ts))+    go :: P.Pipe (Record ts) T.Text m ()+    go = P.map (T.intercalate "," . showFieldsCSV)  -- | Write a header row with column names followed by a line of text -- for each 'Record' to the given file.-writeCSV :: (ColumnHeaders ts, Foldable f, RecordToList ts,-             RecMapMethod ShowCSV ElField ts)-         => FilePath -> f (Record ts) -> IO ()-writeCSV  = writeDSV defaultParser+writeCSV ::+    ( ColumnHeaders ts+    , Foldable f+    , RecordToList ts+    , RecMapMethod ShowCSV ElField ts+    ) =>+    FilePath+    -> f (Record ts)+    -> IO ()+writeCSV = writeDSV defaultParser  -- | Write a header row with column names followed by a line of text -- for each 'Record' to the given file.-writeDSV :: (ColumnHeaders ts, Foldable f, RecordToList ts,-             RecMapMethod ShowCSV ElField ts)-         => ParserOptions -> FilePath -> f (Record ts) -> IO ()-writeDSV opts fp recs = P.runSafeT . P.runEffect $-                   produceDSV opts recs >-> P.map T.pack >-> consumeTextLines fp+writeDSV ::+    ( ColumnHeaders ts+    , Foldable f+    , RecordToList ts+    , RecMapMethod ShowCSV ElField ts+    ) =>+    ParserOptions+    -> FilePath+    -> f (Record ts)+    -> IO ()+writeDSV opts fp recs =+    P.runSafeT . P.runEffect $+        produceDSV opts recs >-> P.map T.pack >-> consumeTextLines fp

@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase,-             ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures, ScopedTypeVariables #-} module Frames.ColumnTypeable where import Control.Monad (MonadPlus) import Data.Maybe (fromMaybe)

@@ -1,161 +1,226 @@-{-# LANGUAGE BangPatterns, CPP, ConstraintKinds, DataKinds,-             FlexibleContexts, FlexibleInstances, GADTs, InstanceSigs,-             KindSignatures, LambdaCase, MultiParamTypeClasses,-             OverloadedStrings, QuasiQuotes, RankNTypes,-             ScopedTypeVariables, TemplateHaskell, TypeApplications,-             TypeFamilies, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Frames.ColumnUniverse (-  CoRec, Columns, ColumnUniverse, ColInfo,-  CommonColumns, CommonColumnsCat, parsedTypeRep+    CoRec,+    Columns,+    ColumnUniverse,+    ColInfo,+    CommonColumns,+    CommonColumnsCat,+    parsedTypeRep, ) where+ import Data.Maybe (fromMaybe) #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup((<>))) #endif+import Data.Either (fromRight) import qualified Data.Text as T import Data.Vinyl import Data.Vinyl.CoRec import Data.Vinyl.Functor-import Data.Vinyl.TypeLevel (RIndex, NatToInt)-import Frames.ColumnTypeable+import Data.Vinyl.TypeLevel (NatToInt, RIndex) import Frames.Categorical+import Frames.ColumnTypeable import Language.Haskell.TH  -- | Extract a function to test whether some value of a given type -- could be read from some 'T.Text'.-inferParseable :: Parseable a => T.Text -> (Maybe :. Parsed) a+inferParseable :: (Parseable a) => T.Text -> (Maybe :. Parsed) a inferParseable = Compose . parse  -- | Helper to call 'inferParseable' on variants of a 'CoRec'.-inferParseable' :: Parseable a => (((->) T.Text) :. (Maybe :. Parsed)) a+inferParseable' :: (Parseable a) => ((->) T.Text :. (Maybe :. Parsed)) a inferParseable' = Compose inferParseable  -- * Record Helpers -tryParseAll :: forall ts. (RecApplicative ts, RPureConstrained Parseable ts)-            => T.Text -> Rec (Maybe :. Parsed) ts+tryParseAll ::+    forall ts.+    (RecApplicative ts, RPureConstrained Parseable ts) =>+    T.Text+    -> Rec (Maybe :. Parsed) ts tryParseAll = rtraverse getCompose funs-  where funs :: Rec (((->) T.Text) :. (Maybe :. Parsed)) ts-        funs = rpureConstrained @Parseable inferParseable'+  where+    funs :: Rec (((->) T.Text) :. (Maybe :. Parsed)) ts+    funs = rpureConstrained @Parseable inferParseable'  -- * Column Type Inference  -- | Information necessary for synthesizing row types and comparing -- types. newtype ColInfo a = ColInfo (Either (String -> Q [Dec]) Type, Parsed a)-instance Show a => Show (ColInfo a) where-  show (ColInfo (t,p)) = "(ColInfo {"-                         ++ either (const "cat") show t-                         ++ ", "-                         ++ show (discardConfidence p) ++"})" -parsedToColInfo :: Parseable a => Parsed a -> ColInfo a+instance (Show a) => Show (ColInfo a) where+    show (ColInfo (t, p)) =+        "(ColInfo {"+            ++ either (const "cat") show t+            ++ ", "+            ++ show (discardConfidence p)+            ++ "})"++parsedToColInfo :: (Parseable a) => Parsed a -> ColInfo a parsedToColInfo x = case getConst rep of-                      Left dec -> ColInfo (Left dec, x)-                      Right ty ->-                        ColInfo (Right ty, x)-  where rep = representableAsType x+    Left dec -> ColInfo (Left dec, x)+    Right ty ->+        ColInfo (Right ty, x)+  where+    rep = representableAsType x  parsedTypeRep :: ColInfo a -> Parsed Type-parsedTypeRep (ColInfo (t,p)) =-  const (either (const (ConT (mkName "Categorical"))) id t) <$> p+parsedTypeRep (ColInfo (t, p)) =+    fromRight (ConT (mkName "Categorical")) t <$ p  -- | Map 'Type's we know about (with a special treatment of -- synthesized types for categorical variables) to 'Int's for ordering -- purposes. orderParsePriorities :: Parsed (Maybe Type) -> Maybe Int orderParsePriorities x =-  case discardConfidence x of-    Nothing -> Just 1 -- categorical variable-    Just t-      | t == tyText -> Just (0 + uncertainty)-      | t == tyDbl -> Just (2 + uncertainty)-      | t == tyInt -> Just (3 + uncertainty)-      | t == tyBool -> Just (4 + uncertainty)-      | otherwise -> Nothing-  where tyText = ConT (mkName "Text")-        tyDbl = ConT (mkName "Double")-        tyInt = ConT (mkName "Int")-        tyBool = ConT (mkName "Bool")-        uncertainty = case x of Definitely _ -> 0; Possibly _ -> 5+    case discardConfidence x of+        Nothing -> Just (1 + 6) -- categorical variable+        Just t+            | t == tyText -> Just (0 + uncertainty)+            | t == tyDbl -> Just (2 + uncertainty)+            | t == tyInt -> Just (3 + uncertainty)+            | t == tyBool -> Just (4 + uncertainty)+            | otherwise -> Just (5 + uncertainty) -- Unknown type+  where+    tyText = ConT (mkName "Text")+    tyDbl = ConT (mkName "Double")+    tyInt = ConT (mkName "Int")+    tyBool = ConT (mkName "Bool")+    uncertainty = case x of Definitely _ -> 0; Possibly _ -> 6  -- | We use a join semi-lattice on types for representations. The--- bottom of the lattice is effectively an error (we have nothing to--- represent), @Bool < Int@, @Int < Double@, and @forall n. n <= Text@.+--  bottom of the lattice is effectively an error (we have nothing to+--  represent), @Bool < Int@, @Int < Double@, and @forall n. n <= Text@. ----- The high-level goal here is that we will pick the "greater" of two--- choices in 'bestRep'. A 'Definitely' parse result is preferred over--- a 'Possibly' parse result. If we have two distinct 'Possibly' parse--- results, we give up. If we have two distinct 'Definitely' parse--- results, we are in dangerous waters: all data is parseable at--- /both/ types, so which do we default to? The defaulting choices--- made here are described in the previous paragraph. If there is no--- defaulting rule, we give up (i.e. use 'T.Text' as a--- representation).+--  The high-level goal here is that we will pick the "greater" of two+--  choices in 'bestRep'. A 'Definitely' parse result is preferred over+--  a 'Possibly' parse result. If we have two distinct 'Possibly' parse+--  results, we give up. If we have two distinct 'Definitely' parse+--  results, we are in dangerous waters: all data is parseable at+--  /both/ types, so which do we default to? The defaulting choices+--  made here are described in the previous paragraph. If there is no+--  defaulting rule, we give up (i.e. use 'T.Text' as a+--  representation). lubTypes :: Parsed (Maybe Type) -> Parsed (Maybe Type) -> Maybe Ordering lubTypes x y = compare <$> orderParsePriorities y <*> orderParsePriorities x -instance (T.Text ∈ ts, RPureConstrained Parseable ts) => Monoid (CoRec ColInfo ts) where-  mempty = CoRec (ColInfo ( Right (ConT (mkName "Text")), Possibly T.empty))+-- instance (T.Text ∈ ts, RPureConstrained Parseable ts) => Monoid (CoRec ColInfo ts) where+--     mempty = CoRec (ColInfo (Right (ConT (mkName "Text")), Possibly T.empty))  -- | A helper For the 'Semigroup' instance below.-mergeEqTypeParses :: forall ts. (RPureConstrained Parseable ts, T.Text ∈ ts)-                  => CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts-mergeEqTypeParses x@(CoRec _) y = fromMaybe definitelyText-                                $ coRecTraverse getCompose-                                                (coRecMapC @Parseable aux x)-  where definitelyText = CoRec (ColInfo (Right (ConT (mkName "Text")), Definitely T.empty))-        aux :: forall a. (Parseable a, NatToInt (RIndex a ts))-            => ColInfo a -> (Maybe :. ColInfo) a-        aux (ColInfo (_, pX)) =-          case asA' @a y of+mergeEqTypeParses ::+    forall ts.+    (RPureConstrained Parseable ts, T.Text ∈ ts) =>+    CoRec ColInfo ts+    -> CoRec ColInfo ts+    -> CoRec ColInfo ts+mergeEqTypeParses x@(CoRec _) y =+    fromMaybe definitelyText $+        coRecTraverse+            getCompose+            (coRecMapC @Parseable aux x)+  where+    definitelyText = CoRec (ColInfo (Right (ConT (mkName "Text")), Definitely T.empty))+    aux ::+        forall a.+        (Parseable a, NatToInt (RIndex a ts)) =>+        ColInfo a+        -> (Maybe :. ColInfo) a+    aux (ColInfo (_, pX)) =+        case asA' @a y of             Nothing -> Compose Nothing             Just (ColInfo (_, pY)) ->-              maybe (Compose Nothing)+                maybe+                    (Compose Nothing)                     (Compose . Just . parsedToColInfo)                     (parseCombine pX pY) -instance (T.Text ∈ ts, RPureConstrained Parseable ts)-  => Semigroup (CoRec ColInfo ts) where-  x@(CoRec (ColInfo (tyX, pX))) <> y@(CoRec (ColInfo (tyY, pY))) =-    case lubTypes (const (either (const Nothing) Just tyX) <$> pX)-                  (const (either (const Nothing) Just tyY) <$> pY) of-      Just GT -> x-      Just LT -> y-      Just EQ -> mergeEqTypeParses x y-      Nothing -> mempty+instance+    (T.Text ∈ ts, RPureConstrained Parseable ts) =>+    Semigroup (CoRec ColInfo ts)+    where+    (<>) :: (T.Text ∈ ts, RPureConstrained Parseable ts) => CoRec ColInfo ts -> CoRec ColInfo ts -> CoRec ColInfo ts+    x@(CoRec (ColInfo (tyX, pX))) <> y@(CoRec (ColInfo (tyY, pY))) =+        case lubTypes+            (either (const Nothing) Just tyX <$ pX)+            (either (const Nothing) Just tyY <$ pY) of+            Just GT -> x+            Just LT -> y+            Just EQ -> mergeEqTypeParses x y+            Nothing -> undefined -- mempty  -- | Find the best (i.e. smallest) 'CoRec' variant to represent a--- parsed value. For inspection in GHCi after loading this module,--- consider this example:+--  parsed value. For inspection in GHCi after loading this module,+--  consider this example: ----- >>> :set -XTypeApplications--- >>> :set -XOverloadedStrings--- >>> import Data.Vinyl.CoRec (foldCoRec)--- >>> foldCoRec parsedTypeRep (bestRep @CommonColumns "2.3")--- Definitely Double-bestRep :: forall ts.-           (RPureConstrained Parseable ts,-            FoldRec ts ts,-            RecApplicative ts, T.Text ∈ ts)-        => T.Text -> CoRec ColInfo ts+--  >>> :set -XTypeApplications+--  >>> :set -XOverloadedStrings+--  >>> import Data.Vinyl.CoRec (foldCoRec)+--  >>> foldCoRec parsedTypeRep (bestRep @CommonColumns "2.3")+--  Definitely Double+bestRep ::+    forall ts.+    ( RPureConstrained Parseable ts+    , RPureConstrained (ShowF ColInfo) ts+    , FoldRec ts ts+    , RecApplicative ts+    , T.Text ∈ ts+    ) =>+    T.Text+    -> CoRec ColInfo ts bestRep t-  | T.null t || t == "NA" = (CoRec (parsedToColInfo (Possibly T.empty)))-  | otherwise = coRecMapC @Parseable parsedToColInfo-              . fromMaybe (CoRec (Possibly T.empty :: Parsed T.Text))-              . firstField-              . (tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)-              $ t-{-# INLINABLE bestRep #-}+    -- \| trace (show (aux t)) False = undefined+    | T.null t || t == "NA" = CoRec (parsedToColInfo (Possibly T.empty))+    | otherwise =+        coRecMapC @Parseable parsedToColInfo+            . fromMaybe (CoRec (Possibly T.empty :: Parsed T.Text))+            . firstField+            . (tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)+            $ t+-- where+--   aux =+--       coRecMapC @Parseable parsedToColInfo+--           . fromMaybe (CoRec (Possibly T.empty :: Parsed T.Text))+--           . firstField+--           . (tryParseAll :: T.Text -> Rec (Maybe :. Parsed) ts)+{-# INLINEABLE bestRep #-} -instance (RPureConstrained Parseable ts, FoldRec ts ts,-          RecApplicative ts, T.Text ∈ ts) =>-    ColumnTypeable (CoRec ColInfo ts) where-  colType (CoRec (ColInfo (t, _))) = t-  {-# INLINE colType #-}-  inferType = bestRep-  {-# INLINABLE inferType #-}+instance+    ( RPureConstrained Parseable ts+    , FoldRec ts ts+    , RPureConstrained (ShowF ColInfo) ts+    , RecApplicative ts+    , T.Text ∈ ts+    ) =>+    ColumnTypeable (CoRec ColInfo ts)+    where+    colType (CoRec (ColInfo (t, _))) = t+    {-# INLINE colType #-}+    inferType = bestRep+    {-# INLINEABLE inferType #-}  #if !MIN_VERSION_vinyl(0,11,0) instance forall ts. (RPureConstrained Show ts, RecApplicative ts)@@ -175,7 +240,7 @@ type ColumnUniverse = CoRec ColInfo  -- | A universe of common column variants. These are the default--- column types that @Frames@ can infer. See the--- <http://acowley.github.io/Frames/#sec-4 Tutorial> for an example of--- extending the default types with your own.+--  column types that @Frames@ can infer. See the+--  <http://acowley.github.io/Frames/#sec-4 Tutorial> for an example of+--  extending the default types with your own. type Columns = ColumnUniverse CommonColumns

@@ -2,6 +2,7 @@              QuasiQuotes, RecordWildCards, RoleAnnotations,              ScopedTypeVariables, TemplateHaskell, TupleSections,              TypeApplications, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} -- | 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.@@ -25,6 +26,7 @@ import qualified Pipes as P import qualified Pipes.Prelude as P import qualified Pipes.Safe as P+import Data.Vinyl.CoRec (ShowF)  -- | Generate a column type. recDec :: [Type] -> Type@@ -70,7 +72,7 @@ -- | 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)+       -> Either (String -> Q [Dec]) Type        -> Q (Type, [Dec]) colDec prefix rowName colName colTypeGen = do   (colTy, extraDecs) <- either colDecsHelper (pure . (,[])) colTypeGen@@ -139,8 +141,8 @@  -- -- | 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))) |]+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@@ -194,7 +196,7 @@ -- | 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)+                   (c ~ CoRec ColInfo a, ColumnTypeable c, Semigroup c)                 => RowGen a -> DecsQ tableTypesText' RowGen {..} =   do colNames <- runIO . P.runSafeT $@@ -228,7 +230,7 @@ -- 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)+tableTypes' :: forall a c. (c ~ CoRec ColInfo a, ColumnTypeable c, Semigroup c, RPureConstrained (ShowF ColInfo) a)             => RowGen a -> DecsQ tableTypes' (RowGen {..}) =   do headers <- runIO . P.runSafeT@@ -256,3 +258,4 @@           case mColNm of             Just n -> pure (ConT n, []) -- Column's type was already defined             Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm colTy+

@@ -1,56 +1,58 @@-{-# LANGUAGE DeriveLift, OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+ module DataCSV where-import Control.Monad ((>=>))+ import Data.Bifunctor (first)-import qualified Data.ByteString as BS-import qualified Data.HashMap.Lazy as H-import Data.Maybe (catMaybes)+import qualified Data.Foldable as F import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Text.Encoding (decodeUtf8)-import Language.Haskell.TH.Syntax (Lift(..))-import Text.Toml-import Text.Toml.Types (Node (VTable, VString), Table)+import Language.Haskell.TH.Syntax (Lift (..))+import qualified Toml+import Validation -data CsvExample = CsvExample {-  name :: String-  , csv :: String-  , generated :: String }-  deriving Lift+data CsvExample = CsvExample+    { name :: String+    , csv :: String+    , generated :: String+    }+    deriving (Lift, Show) --- instance Lift CsvExample where---   lift (CsvExample n c g) = [e| CsvExample n c g |]+keyText :: Toml.Key -> T.Text+keyText = F.fold . cleanup . map Toml.unPiece . F.toList . Toml.unKey+  where+    -- Top-level table names are parsed as @"name" :|+    -- ["name"]@. Remove that duplication here.+    cleanup [x, y] | x == y = [x]+    cleanup x = x -examplesFrom :: FilePath -> IO [CsvExample]-examplesFrom fp =-  (either error id-   . ((first show . parseTomlDoc "examples") >=> go)-   . decodeUtf8)-  <$> BS.readFile fp-  where go :: Table -> Either String [CsvExample]-        go = fmap catMaybes . mapM (uncurry ex . first T.unpack) . H.toList-        ex :: String -> Node -> Either String (Maybe CsvExample)-        ex k (VTable v) =-          do c <- case H.lookup "csv" v of-                    Nothing -> Right Nothing -- ("No csv key in "++k)-                    Just (VString c) -> Right (Just (T.unpack c))-                    Just _ -> Left ("csv key not a string in " ++ k)-             g <- case H.lookup "generated" v of-                    Nothing -> Left ("No generated key in " ++ k)-                    Just (VString g) -> Right (Just (T.unpack g))-                    Just _ -> Left ("generated key not a string in " ++ k)-             return (CsvExample k <$> c <*> g)-        ex k _ = Left (k ++ " is not a table")+-- | Parse a TOML file that is a top-level table whose values are all+-- the same type. The @tomland@ codec API is centered around starting+-- with a key, but a top-level table does not have a key, so we must+-- use the lower level 'Toml.parse' and 'Toml.tomlTables' before+-- repeatedly applying the provided 'Toml.TomlCodec'.+parseFileOf :: forall a. Toml.TomlCodec a -> T.Text -> Either [T.Text] [(T.Text, a)]+parseFileOf codec =+    first (map Toml.prettyTomlDecodeError)+        . validationToEither+        . traverse (uncurry go)+        . Toml.toList+        . Toml.tomlTables+        . either (error . show) id+        . Toml.parse+  where+    go :: Toml.Key -> Toml.TOML -> Validation [Toml.TomlDecodeError] (T.Text, a)+    go k v = (keyText k,) <$> Toml.runTomlCodec codec v -generatedFrom :: FilePath -> String -> IO String-generatedFrom fp key = (either error id . (>>= go)-                        . first show . parseTomlDoc "examples")-                       <$> T.readFile fp-  where go :: Table -> Either String String-        go toml = do tbl <- case H.lookup (T.pack key) toml of-                              Just (VTable t) -> Right t-                              _ -> Left (key ++ " is not a table")-                     case H.lookup "generated" tbl of-                       Just (VString g) -> Right (T.unpack g)-                       Just _ -> Left ("generated key not a string in " ++ key)-                       Nothing -> Left ("No generated key in " ++ key)+parseExamples :: FilePath -> IO (Either [T.Text] [CsvExample])+parseExamples = fmap (fmap (map mkExample) . parseFileOf exampleCodec) . T.readFile+  where+    exampleCodec = Toml.pair (Toml.string "csv") (Toml.string "generated")+    mkExample (name', (csv', generated')) =+        CsvExample (T.unpack name') csv' generated'++-- | Wraps 'parseExamples' to call 'error' on any parse errors.+examplesFrom :: FilePath -> IO [CsvExample]+examplesFrom = fmap (either (error . show) id) . parseExamples

@@ -21,7 +21,7 @@  -- | Make template haskell-generated code more readable by -- unqualifying common names, making type operators infix, erasing--- inferrable types, and adding a bit of whitespace.+-- inferable types, and adding a bit of whitespace. makePretty :: String -> String makePretty = -- Add new lines before type synonym definitions              replace' "\ntype " "\n\ntype "@@ -29,13 +29,14 @@              . (!! 10) . iterate (replace infixCons)              . replace infixNil              . replace infixCol-               -- Erase inferrable type+               -- Erase inferable type              . replace ((\x y -> x ++ " ∈ " ++ y)                         <$> ("RElem " *> some (psym (not . isSpace)))                         <*> ((some (psym isSpace) *> some (psym (not . isSpace)))                              <* " (RIndex " <* some (psym (/= ')')) <* ")"))                -- Unqualify names              . replace' "Frames.CSV.ParserOptions" "ParserOptions"+             . replace' "GHC.Maybe." ""              . replace' "GHC.Base." ""              . replace' "GHC.Types." ""              . replace' "Data.Vinyl.Core." ""

@@ -102,72 +102,72 @@                                        Rec g_23 rs_24 -> f_22 (Rec g_23 rs_24) managerId' = rlens' @ManagerId""" -[managers_employees]-generated = """-type ManagerRec = Record [Id, Manager, Age, Pay]-managerRecParser :: ParserOptions-managerRecParser = ParserOptions Nothing (T.pack ",") (Frames.CSV.RFC4180Quoting '"')+# [managers_employees]+# generated = """+# type ManagerRec = Record [Id, Manager, Age, Pay]+# managerRecParser :: ParserOptions+# managerRecParser = ParserOptions Nothing (T.pack ",") (Frames.CSV.RFC4180Quoting '"') -type Id = "id" :-> Int-id :: forall f_0 rs_1 . (Functor f_0, Id ∈ rs_1) =>-                        (Int -> f_0 Bool) -> Record rs_1 -> f_0 (Record rs_1)-id = rlens @Id . rfield-id' :: forall f_2 g_3 rs_4 . (Functor f_2, Functor g_3, Id ∈ rs_4) =>-                             (g_3 Id -> f_2 (g_3 Id)) -> Rec g_3 rs_4 -> f_2 (Rec g_3 rs_4)-id' = rlens' @Id+# type Id = "id" :-> Int+# id :: forall f_0 rs_1 . (Functor f_0, Id ∈ rs_1) =>+#                         (Int -> f_0 Bool) -> Record rs_1 -> f_0 (Record rs_1)+# id = rlens @Id . rfield+# id' :: forall f_2 g_3 rs_4 . (Functor f_2, Functor g_3, Id ∈ rs_4) =>+#                              (g_3 Id -> f_2 (g_3 Id)) -> Rec g_3 rs_4 -> f_2 (Rec g_3 rs_4)+# id' = rlens' @Id -type Manager = "manager" :-> Text-manager :: forall f_5 rs_6 . (Functor f_5, Manager ∈ rs_6) =>-                             (Text -> f_5 Text) -> Record rs_6 -> f_5 (Record rs_6)-manager = rlens @Manager . rfield-manager' :: forall f_7 g_8 rs_9 . (Functor f_7,-                                   Manager ∈ rs_9) =>-                                  (g_8 Manager -> f_7 (g_8 Manager)) -> Rec g_8 rs_9 -> f_7 (Rec g_8 rs_9)-manager' = rlens' @Manager+# type Manager = "manager" :-> Text+# manager :: forall f_5 rs_6 . (Functor f_5, Manager ∈ rs_6) =>+#                              (Text -> f_5 Text) -> Record rs_6 -> f_5 (Record rs_6)+# manager = rlens @Manager . rfield+# manager' :: forall f_7 g_8 rs_9 . (Functor f_7,+#                                    Manager ∈ rs_9) =>+#                                   (g_8 Manager -> f_7 (g_8 Manager)) -> Rec g_8 rs_9 -> f_7 (Rec g_8 rs_9)+# manager' = rlens' @Manager -type Age = "age" :-> Int-age :: forall f_10 rs_11 . (Functor f_10, Age ∈ rs_11) =>-                           (Int -> f_10 Int) -> Record rs_11 -> f_10 (Record rs_11)-age = rlens @Age . rfield-age' :: forall f_12 g_13 rs_14 . (Functor f_12,-                                  Age ∈ rs_14) =>-                                 (g_13 Age -> f_12 (g_13 Age)) -> Rec g_13 rs_14 -> f_12 (Rec g_13 rs_14)-age' = rlens' @Age+# type Age = "age" :-> Int+# age :: forall f_10 rs_11 . (Functor f_10, Age ∈ rs_11) =>+#                            (Int -> f_10 Int) -> Record rs_11 -> f_10 (Record rs_11)+# age = rlens @Age . rfield+# age' :: forall f_12 g_13 rs_14 . (Functor f_12,+#                                   Age ∈ rs_14) =>+#                                  (g_13 Age -> f_12 (g_13 Age)) -> Rec g_13 rs_14 -> f_12 (Rec g_13 rs_14)+# age' = rlens' @Age -type Pay = "pay" :-> Double-pay :: forall f_15 rs_16 . (Functor f_15, Pay ∈ rs_16) =>-                           (Double -> f_15 Double) -> Record rs_16 -> f_15 (Record rs_16)-pay = rlens @Pay . rfield-pay' :: forall f_17 g_18 rs_19 . (Functor f_17,-                                  Pay ∈ rs_19) =>-                                 (g_18 Pay -> f_17 (g_18 Pay)) -> Rec g_18 rs_19 -> f_17 (Rec g_18 rs_19)-pay' = rlens' @Pay+# type Pay = "pay" :-> Double+# pay :: forall f_15 rs_16 . (Functor f_15, Pay ∈ rs_16) =>+#                            (Double -> f_15 Double) -> Record rs_16 -> f_15 (Record rs_16)+# pay = rlens @Pay . rfield+# pay' :: forall f_17 g_18 rs_19 . (Functor f_17,+#                                   Pay ∈ rs_19) =>+#                                  (g_18 Pay -> f_17 (g_18 Pay)) -> Rec g_18 rs_19 -> f_17 (Rec g_18 rs_19)+# pay' = rlens' @Pay -type EmployeeRec = Record ["id" :-> Int, "employee" :-> Text, "age" :-> Int, "pay" :-> Double, "manager_id" :-> Int]-employeeRecParser :: ParserOptions-employeeRecParser = ParserOptions Nothing (T.pack ",") (Frames.CSV.RFC4180Quoting '"')+# type EmployeeRec = Record ["id" :-> Int, "employee" :-> Text, "age" :-> Int, "pay" :-> Double, "manager_id" :-> Int]+# employeeRecParser :: ParserOptions+# employeeRecParser = ParserOptions Nothing (T.pack ",") (Frames.CSV.RFC4180Quoting '"') -type Employee = "employee" :-> Text-employee :: forall f_5 rs_6 . (Functor f_5, Employee ∈ rs_6) =>-                              (Text -> f_5 Text) -> Record rs_6 -> f_5 (Record rs_6)-employee = rlens @Employee . rfield-employee' :: forall f_7 g_8 rs_9 . (Functor f_7,-                                    Employee ∈ rs_9) =>-                                   (g_8 Employee -> f_7 (g_8 Employee)) -> Rec g_8 rs_9 -> f_7 (Rec g_8 rs_9)-employee' = rlens' @Employee+# type Employee = "employee" :-> Text+# employee :: forall f_5 rs_6 . (Functor f_5, Employee ∈ rs_6) =>+#                               (Text -> f_5 Text) -> Record rs_6 -> f_5 (Record rs_6)+# employee = rlens @Employee . rfield+# employee' :: forall f_7 g_8 rs_9 . (Functor f_7,+#                                     Employee ∈ rs_9) =>+#                                    (g_8 Employee -> f_7 (g_8 Employee)) -> Rec g_8 rs_9 -> f_7 (Rec g_8 rs_9)+# employee' = rlens' @Employee -type Age = "age" :-> Int+# type Age = "age" :-> Int -type ManagerId = "manager_id" :-> Int-managerId :: forall f_20 rs_21 . (Functor f_20, ManagerId ∈ rs_21) =>-                                 (Int -> f_20 Int) -> Record rs_21 -> f_20 (Record rs_21)-managerId = rlens @ManagerId . rfield-managerId' :: forall f_22 g_23 rs_24 . (Functor f_22,-                                        ManagerId ∈ rs_24) =>-                                       (g_23 ManagerId -> f_22 (g_23 ManagerId)) ->-                                       Rec g_23 rs_24 -> f_22 (Rec g_23 rs_24)-managerId' = rlens' @ManagerId-"""+# type ManagerId = "manager_id" :-> Int+# managerId :: forall f_20 rs_21 . (Functor f_20, ManagerId ∈ rs_21) =>+#                                  (Int -> f_20 Int) -> Record rs_21 -> f_20 (Record rs_21)+# managerId = rlens @ManagerId . rfield+# managerId' :: forall f_22 g_23 rs_24 . (Functor f_22,+#                                         ManagerId ∈ rs_24) =>+#                                        (g_23 ManagerId -> f_22 (g_23 ManagerId)) ->+#                                        Rec g_23 rs_24 -> f_22 (Rec g_23 rs_24)+# managerId' = rlens' @ManagerId+# """  [double_gt_bool] csv = """