diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,36 @@ +# 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. +- Add `inferencePrefix` that controls how many lines of the input file are used for column type inference (default is 1000). +- Add `readTableDebug` that loads and parses a data frame as `readTable`, but additionally prints lines that failed to parse to `stderr`. + +# 0.7.1 + +- Add `showFrame`, `printFrame`, `takeRows`, and `dropRows` to the `Frames.Exploration` module. These helpers for working with `Frames` are re-exported from the `Frames` module itself. Thanks to @chfin. + +- GHC-9.0.1 support. + +# 0.7.0 + +GHC-8.10 support in Vinyl requires a major version bump. + +# 0.6.3 + +- Fix support for categorical column names that include spaces (@epn09) + +# 0.6.0 +Support external CSV tokenizers + +Internal functionality is now defined more cleanly atop a stream of rows already broken into columns (rather than a stream of rows that we quietly break into columns ourself). This permits the use of external parsers such as provided by the new [Frames-dsv](https://hackage.haskell.org/package/Frames-dsv) package that supplies a CSV parser built atop `hw-dsv`. + +The built-in CSV parser remains for ease of installation. + +# 0.5.1 +GHC 8.6 compatibility + # 0.5.0 - Renamed the `rgetf` and `rputf` exported by the `Frames` module to `rgetField` and `rputField`. This avoids clashing with the same names exported by `vinyl` and further advances the process of eliminating the old `Frames` `Col` type in favor of `vinyl`'s `ElField`. diff --git a/Frames.cabal b/Frames.cabal --- a/Frames.cabal +++ b/Frames.cabal @@ -1,6 +1,6 @@ name: Frames -version: 0.5.1 -synopsis: Data frames For working with tabular data files +version: 0.7.4.2 +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 @@ -11,11 +11,11 @@ license-file: LICENSE author: Anthony Cowley maintainer: acowley@gmail.com -copyright: Copyright (C) 2014-2015 Anthony Cowley +copyright: Copyright (C) 2014-2018 Anthony Cowley category: Data build-type: Simple extra-source-files: benchmarks/*.hs benchmarks/*.py - demo/Main.hs CHANGELOG.md README.md + demo/framestack/app/Main.hs CHANGELOG.md README.md data/GetData.hs test/examples.toml test/data/managers.csv test/data/employees.csv @@ -25,10 +25,12 @@ test/data/prestigeNoHeader.csv test/data/prestigePartial.csv test/data/catSmall.csv test/data/catLarge.csv + test/data/multiline.csv + test/data/issue145.csv data/left1.csv data/right1.csv data/left_summary.csv data/FL2.csv cabal-version: >=1.10 -tested-with: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.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 @@ -57,42 +59,47 @@ Frames.TypeLevel Frames.Joins Frames.ExtraInstances + Frames.Utils other-extensions: DataKinds, GADTs, KindSignatures, TypeFamilies, TypeOperators, ConstraintKinds, StandaloneDeriving, UndecidableInstances, ScopedTypeVariables, OverloadedStrings, TypeApplications - build-depends: base >=4.8 && <4.13, - ghc-prim >=0.3 && <0.6, - primitive >= 0.6 && < 0.7, - 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.12, + primitive >= 0.6 && < 0.10, + text >= 1.1.1.0 && < 2.2, + template-haskell >= 2.10 && < 2.22, + transformers >= 0.5.6 && < 0.7, + 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, - vinyl >= 0.10.0 && < 0.11, - discrimination, - contravariant, - hashable, - deepseq >= 1.4, - containers, - vector-th-unbox >= 0.2.1.6 + bytestring < 0.13, + vinyl >= 0.13.0 && < 0.15, + discrimination >= 0.4 && < 0.6, + contravariant < 1.6, + hashable >= 1.3 && < 1.5, + deepseq >= 1.4 && < 1.6, + containers < 0.8, + 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 main-is: GetData.hs if flag(demos) - build-depends: base, bytestring, http-client >= 0.4.3, zip-archive, directory + build-depends: + base, bytestring, + http-client >= 0.4.3, + http-client-tls, + zip-archive, directory hs-source-dirs: data default-language: Haskell2010 ghc-options: -Wall @@ -141,9 +148,9 @@ build-depends: base, list-t, microlens, transformers, Frames, vector, text, template-haskell, ghc-prim, readable, pipes - hs-source-dirs: demo + hs-source-dirs: demo/framestack/app default-language: Haskell2010 - ghc-options: -O2 + ghc-options: -O2 -fsimpl-tick-factor=200 -- ghc-options: -O2 -fllvm executable tutorial @@ -169,7 +176,7 @@ hs-source-dirs: benchmarks default-language: Haskell2010 -- ghc-options: -O2 - ghc-options: -O2 -fllvm + ghc-options: -O2 -fllvm -fsimpl-tick-factor=200 -- A demonstration of dealing with missing data. Provided for source -- code and experimentation rather than a useful executable. @@ -211,18 +218,38 @@ hs-source-dirs: demo default-language: Haskell2010 +executable modcsv + if !flag(demos) + buildable: False + main-is: ModifyCSV.hs + if flag(demos) + build-depends: base, Frames, microlens, pipes + 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 main-is: Spec.hs other-modules: DataCSV PrettyTH Temp LatinTest Issue114 NoHeader UncurryFold UncurryFoldNoHeader UncurryFoldPartialData - Categorical + 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, - attoparsec, lens + 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,15 +17,14 @@ If you have a CSV data where the values of each column may be classified by a single type, and ideally you have a header row giving each column a name, you may simply want to avoid writing out the Haskell type corresponding to each row. `Frames` provides `TemplateHaskell` machinery to infer a Haskell type for each row of your data set, thus preventing the situation where your code quietly diverges from your data. -We generate a collection of definitions generated by inspecting the data file at compile time (using `tableTypes`), then, at runtime, load that data into column-oriented storage in memory (an **in-core** array of structures (AoS)). We're going to compute the average ratio of two columns, so we'll use the `foldl` library. Our fold will project the columns we want, and apply a function that divides one by the other after appropriate numeric type conversions. Here is the entirety of that [program](https://github.com/acowley/Frames/tree/master/test/UncurryFold.hs). +We generate a collection of definitions generated by inspecting the data file at compile time (using `tableTypes`), then, at runtime, load that data into column-oriented storage in memory with a row-oriented interface (an **in-core** array of structures (AoS)). We're going to compute the average ratio of two columns, so we'll use the `foldl` library. Our fold will project the columns we want, and apply a function that divides one by the other after appropriate numeric type conversions. Here is the entirety of that [program](https://github.com/acowley/Frames/tree/main/test/UncurryFold.hs). ```haskell -{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell, TypeApplications #-} module UncurryFold where -import qualified Control.Foldl as L -import Data.Vinyl (rcast) -import Data.Vinyl.Curry (runcurryX) -import Frames +import qualified Control.Foldl as L +import Data.Vinyl.Curry ( runcurryX ) +import Frames -- Data set from http://vincentarelbundock.github.io/Rdatasets/datasets.html tableTypes "Row" "test/data/prestige.csv" @@ -46,16 +45,17 @@ ### Missing Header Row -Now consider a case where our data file lacks a header row (I deleted the first row from \`prestige.csv\`). We will provide our own name for the generated row type, our own column names, and, for the sake of demonstration, we will also specify a prefix to be added to every column-based identifier (particularly useful if the column names **do** come from a header row, and you want to work with multiple CSV files some of whose column names coincide). We customize behavior by updating whichever fields of the record produced by `rowGen` we care to change, passing the result to `tableTypes'`. [Link to code.](https://github.com/acowley/Frames/tree/master/test/UncurryFoldNoHeader.hs) +Now consider a case where our data file lacks a header row (I deleted the first row from \`prestige.csv\`). We will provide our own name for the generated row type, our own column names, and, for the sake of demonstration, we will also specify a prefix to be added to every column-based identifier (particularly useful if the column names **do** come from a header row, and you want to work with multiple CSV files some of whose column names coincide). We customize behavior by updating whichever fields of the record produced by `rowGen` we care to change, passing the result to `tableTypes'`. [Link to code.](https://github.com/acowley/Frames/tree/main/test/UncurryFoldNoHeader.hs) ```haskell -{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell, TypeApplications #-} module UncurryFoldNoHeader where -import qualified Control.Foldl as L -import Data.Vinyl (rcast) -import Data.Vinyl.Curry (runcurryX) -import Frames -import Frames.TH (rowGen, RowGen(..)) +import qualified Control.Foldl as L +import Data.Vinyl.Curry ( runcurryX ) +import Frames +import Frames.TH ( rowGen + , RowGen(..) + ) -- Data set from http://vincentarelbundock.github.io/Rdatasets/datasets.html tableTypes' (rowGen "test/data/prestigeNoHeader.csv") @@ -84,7 +84,7 @@ "athletes",11.44,8206,8.13,,3373,NA -We can no longer parse a `Double` for that row, so we will work with row types parameterized by a `Maybe` type constructor. We are substantially filtering our data, so we will perform this operation in a streaming fashion without ever loading the entire table into memory. Our process will be to check if the `prestige` column was parsed, only keeping those rows for which it was not, then project the `income` column from those rows, and finally throw away `Nothing` elements. [Link to code](https://github.com/acowley/Frames/tree/master/test/UncurryFoldPartialData.hs). +We can no longer parse a `Double` for that row, so we will work with row types parameterized by a `Maybe` type constructor. We are substantially filtering our data, so we will perform this operation in a streaming fashion without ever loading the entire table into memory. Our process will be to check if the `prestige` column was parsed, only keeping those rows for which it was not, then project the `income` column from those rows, and finally throw away `Nothing` elements. [Link to code](https://github.com/acowley/Frames/tree/main/test/UncurryFoldPartialData.hs). ```haskell {-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell, TypeApplications, TypeOperators #-} @@ -127,15 +127,45 @@ ## Demos -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. +There are various [demos](https://github.com/acowley/Frames/tree/main/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. +The [benchmark](https://github.com/acowley/Frames/tree/main/benchmarks/InsuranceBench.hs) shows several ways of dealing with data when you want to perform multiple traversals. -Another [demo](https://github.com/acowley/Frames/tree/master/benchmarks/BenchDemo.hs) shows how to fuse multiple passes into one so that the full data set is never resident in memory. A [Pandas version](https://github.com/acowley/Frames/tree/master/benchmarks/panda.py) of a similar program is also provided for comparison. +Another [demo](https://github.com/acowley/Frames/tree/main/benchmarks/BenchDemo.hs) shows how to fuse multiple passes into one so that the full data set is never resident in memory. A [Pandas version](https://github.com/acowley/Frames/tree/main/benchmarks/panda.py) of a similar program is also provided for comparison. This is a trivial program, but shows that performance is comparable to Pandas, and the memory savings of a compiled program are substantial. -![img](https://pbs.twimg.com/media/B71az_CCUAAgscq.png) +First with Pandas, + +```bash +$ nix-shell -p 'python3.withPackages (p: [p.pandas])' --run '$(which time) -f "%Uuser %Ssystem %Eelapsed %PCPU; %Mmaxresident KB" python benchmarks/panda.py' +28.087476512228815 +-81.90356506136422 +0.67user 0.04system 0:00.72elapsed 99%CPU; 79376maxresident KB +``` + +Then with Frames, + +```bash +$ $(which time) -f '%Uuser %Ssystem %Eelapsed %PCPU; %Mmaxresident KB' dist-newstyle/build/x86_64-linux/ghc-8.10.4/Frames-0.7.2/x/benchdemo/build/benchdemo/benchdemo +28.087476512228815 +-81.90356506136422 +0.36user 0.00system 0:00.37elapsed 100%CPU; 5088maxresident KB +``` diff --git a/benchmarks/BenchDemo.hs b/benchmarks/BenchDemo.hs --- a/benchmarks/BenchDemo.hs +++ b/benchmarks/BenchDemo.hs @@ -1,14 +1,25 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell, TypeApplications #-} -- | Demonstration of streaming data processing. Try building with -- cabal (@cabal build benchdemo@), then running in bash with -- something like, -- -- @$ /usr/bin/time -l dist/build/benchdemo/benchdemo 2>&1 | head -n 4@ +-- Or, for cabal-install 3 (using Linux and GHC-8.8.2 as an example), +-- @$ time dist-newstyle/build/x86_64-linux/ghc-8.8.2/Frames-0.6.2/x/benchdemo/build/benchdemo/benchdemo@ +-- Or, for all resource usage on linux (avoid the bash builtin time), +-- @$ $(which time) -v dist-newstyle/build/x86_64-linux/ghc-8.8.2/Frames-0.6.2/x/benchdemo/build/benchdemo/benchdemo@ import qualified Control.Foldl as F import Frames +import Frames.TH (rowGen, RowGen (rowTypeName, inferencePrefix)) import Pipes.Prelude (fold) -tableTypes "Ins" "data/FL2.csv" +-- The simple use of 'tableTypes' commented out here is what one +-- typically uses; it infers column types based the first 1000 rows of +-- the data file. In this data file, however, we need to see more rows +-- to properly identify the types. + +-- tableTypes "Ins" "data/FL2.csv" +tableTypes' (rowGen "data/FL2.csv") { rowTypeName = "Ins", inferencePrefix = 2500 } main :: IO () main = do (lat,lng,n) <- runSafeT $ F.purely fold f (readTable "data/FL2.csv") diff --git a/benchmarks/InsuranceBench.hs b/benchmarks/InsuranceBench.hs --- a/benchmarks/InsuranceBench.hs +++ b/benchmarks/InsuranceBench.hs @@ -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) = diff --git a/data/GetData.hs b/data/GetData.hs --- a/data/GetData.hs +++ b/data/GetData.hs @@ -2,14 +2,16 @@ import Codec.Archive.Zip import qualified Data.ByteString.Lazy.Char8 as B import Data.Maybe (fromJust) +import Data.Monoid (First(..)) import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) import System.Directory (createDirectoryIfMissing) getPrestige :: IO () -getPrestige = do m <- newManager defaultManagerSettings +getPrestige = do m <- newManager tlsManagerSettings httpLbs req m >>= B.writeFile "data/prestige.csv" . responseBody - where Just req = parseUrlThrow "http://vincentarelbundock.github.io/Rdatasets/csv/car/Prestige.csv" + where Just req = parseUrlThrow "https://vincentarelbundock.github.io/Rdatasets/csv/carData/Prestige.csv" getFLinsurance :: IO () getFLinsurance = do m <- newManager defaultManagerSettings @@ -28,6 +30,13 @@ httpLbs req m >>= B.writeFile "data/adult.csv" . B.append colNames + . B.unlines + . map (\ln -> maybe ln id + . getFirst + $ foldMap (First . ($ ln)) + [ B.stripSuffix ", <=50K" + , B.stripSuffix ", >50K" ]) + . B.lines . responseBody where Just req = parseUrlThrow "http://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.data" colNames = "age, workclass, fnlwgt, education, education-num, \ diff --git a/demo/Main.hs b/demo/Main.hs deleted file mode 100644 --- a/demo/Main.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE BangPatterns, DataKinds, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts, TypeApplications, TypeOperators #-} -module Main where -import Data.Functor.Identity -import Frames -import Lens.Micro -import qualified Pipes as P -import qualified Pipes.Prelude as P - -tableTypes "Row" "data/data1.csv" - -tbl :: IO [Row] -tbl = runSafeT . P.toListM $ readTable "data/data1.csv" - -ageDoubler :: (Age ∈ rs) => Record rs -> Record rs -ageDoubler = age %~ (* 2) - -tbl2 :: IO [Row] -tbl2 = runSafeT . P.toListM $ readTable "data/data2.csv" - -tbl2a :: IO [ColFun Maybe Row] -tbl2a = runSafeT . P.toListM $ readTableMaybe "data/data2.csv" - -{- - -REPL examples: - -λ> tbl >>= mapM_ print -{name :-> "joe", age :-> 21} -{name :-> "sue", age :-> 23} -{name :-> "bob", age :-> 44} -{name :-> "laura", age :-> 18} - -λ> tbl2 >>= mapM_ print -{name :-> "joe", age :-> 21} -{name :-> "sue", age :-> 23} -{name :-> "laura", age :-> 18} - -λ> tbl2a >>= mapM_ (putStrLn . showRecF) -{Just (name :-> "joe"), Just (age :-> 21)} -{Just (name :-> "sue"), Just (age :-> 23)} -{Just (name :-> "bob"), Nothing} -{Just (name :-> "laura"), Just (age :-> 18)} - --} - --- Sample data from http://support.spatialkey.com/spatialkey-sample-csv-data/ --- Note: We have to replace carriage returns (\r) with line feed --- characters (\n) for the text library's line parsing to work. -tableTypes "Ins" "data/FL2.csv" - -insuranceTbl :: MonadSafe m => P.Producer Ins m () -insuranceTbl = readTable "data/FL2.csv" - -insMaybe :: MonadSafe m => P.Producer (ColFun Maybe Ins) m () -insMaybe = readTableMaybe "data/FL2.csv" - -type TinyIns = Record [PolicyID, PointLatitude, PointLongitude] - -main :: IO () -main = do itbl <- inCore $ P.for insuranceTbl (P.yield . rcast) - :: IO (P.Producer TinyIns Identity ()) - putStrLn "In-core representation prepared" - let Identity (n,sumLat) = - P.fold (\ !(!i,!s) r -> (i+1, s+rgetField @PointLatitude r)) - (0::Int,0) - id - itbl - putStrLn $ "Considering " ++ show n ++ " records..." - putStrLn $ "Average latitude: " ++ show (sumLat / fromIntegral n) - let Identity sumLong = - P.fold (\ !s r -> (s + rgetField @PointLongitude r)) 0 id itbl - putStrLn $ "Average longitude: " ++ show (sumLong / fromIntegral n) diff --git a/demo/ModifyCSV.hs b/demo/ModifyCSV.hs new file mode 100644 --- /dev/null +++ b/demo/ModifyCSV.hs @@ -0,0 +1,23 @@ +{-# language DataKinds, FlexibleContexts, TemplateHaskell, TypeApplications #-} +-- | A demonstration of ingesting a CSV file, modifying the data (in +-- this case multiplying a column by 2), then writing it back out to a +-- new CSV file. +import Frames +import Frames.CSV (pipeToCSV, consumeTextLines) +import Lens.Micro +import Pipes ((>->), Effect) +import qualified Pipes.Prelude as P + +tableTypes "Row" "data/data1.csv" + +myFun :: Row -> Row +myFun = age %~ (*2) + +myPipeline :: MonadSafe m => Effect m () +myPipeline = readTable "data/data1.csv" + >-> P.map myFun + >-> pipeToCSV + >-> consumeTextLines "data/dataMod.csv" + +main :: IO () +main = runSafeEffect myPipeline diff --git a/demo/Plot.hs b/demo/Plot.hs --- a/demo/Plot.hs +++ b/demo/Plot.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell, TypeApplications #-} module Main where import qualified Data.Vector.Unboxed as V import Diagrams.Backend.Rasterific diff --git a/demo/Plot2.hs b/demo/Plot2.hs --- a/demo/Plot2.hs +++ b/demo/Plot2.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, OverloadedStrings, - TemplateHaskell #-} + TemplateHaskell, TypeApplications #-} import Diagrams.Backend.Rasterific import Diagrams (dims2D, width, height) import Frames @@ -44,6 +44,7 @@ putStrLn $ "The average farmer/fisher is "++ show (fromIntegral age_ / n) ++ " and made " ++ show (fromIntegral inc / n) + mkPlot where aux !(!sumAge, !sumIncome, n) f = (sumAge + f^.age, sumIncome + f^.capitalGain, n+1) -- Independent folds diff --git a/demo/TimeZones/src/Columns.hs b/demo/TimeZones/src/Columns.hs new file mode 100644 --- /dev/null +++ b/demo/TimeZones/src/Columns.hs @@ -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 diff --git a/demo/TimeZones/src/Main.hs b/demo/TimeZones/src/Main.hs new file mode 100644 --- /dev/null +++ b/demo/TimeZones/src/Main.hs @@ -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 diff --git a/demo/TimeZones/src/TimeIn.hs b/demo/TimeZones/src/TimeIn.hs new file mode 100644 --- /dev/null +++ b/demo/TimeZones/src/TimeIn.hs @@ -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) []] ] ] diff --git a/demo/framestack/app/Main.hs b/demo/framestack/app/Main.hs new file mode 100644 --- /dev/null +++ b/demo/framestack/app/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BangPatterns, DataKinds, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts, TypeApplications, TypeOperators #-} +module Main where +import Data.Functor.Identity +import Frames +import Lens.Micro +import qualified Pipes as P +import qualified Pipes.Prelude as P + +tableTypes "Row" "data/data1.csv" + +tbl :: IO [Row] +tbl = runSafeT . P.toListM $ readTable "data/data1.csv" + + +ageDoubler :: (Age ∈ rs) => Record rs -> Record rs +ageDoubler = age %~ (* 2) + +tbl2 :: IO [Row] +tbl2 = runSafeT . P.toListM $ readTable "data/data2.csv" + +tbl2a :: IO [ColFun Maybe Row] +tbl2a = runSafeT . P.toListM $ readTableMaybe "data/data2.csv" + +-- Sample data from http://support.spatialkey.com/spatialkey-sample-csv-data/ +-- Note: We have to replace carriage returns (\r) with line feed +-- characters (\n) for the text library's line parsing to work. +tableTypes "Ins" "data/FL2.csv" + +insuranceTbl :: MonadSafe m => P.Producer Ins m () +insuranceTbl = readTable "data/FL2.csv" + +insMaybe :: MonadSafe m => P.Producer (ColFun Maybe Ins) m () +insMaybe = readTableMaybe "data/FL2.csv" + +type TinyIns = Record [PolicyID, PointLatitude, PointLongitude] + +main :: IO () +main = do itbl <- inCore $ P.for insuranceTbl (P.yield . rcast) + :: IO (P.Producer TinyIns Identity ()) + putStrLn "In-core representation prepared" + let Identity (n,sumLat) = + P.fold (\ !(!i,!s) r -> (i+1, s+rgetField @PointLatitude r)) + (0::Int,0) + id + itbl + putStrLn $ "Considering " ++ show n ++ " records..." + putStrLn $ "Average latitude: " ++ show (sumLat / fromIntegral n) + let Identity sumLong = + P.fold (\ !s r -> (s + rgetField @PointLongitude r)) 0 id itbl + putStrLn $ "Average longitude: " ++ show (sumLong / fromIntegral n) diff --git a/src/Frames.hs b/src/Frames.hs --- a/src/Frames.hs +++ b/src/Frames.hs @@ -40,7 +40,7 @@ RDelete, RecAll) import Frames.Col ((:->), pattern Col) import Frames.ColumnUniverse -import Frames.CSV (readTable, readTableOpt, readTableMaybe, pipeTable, pipeTableMaybe) +import Frames.CSV (readTable, readTableOpt, readTableMaybe, readTableDebug, pipeTable, pipeTableMaybe) import Frames.Exploration import Frames.Frame import qualified Frames.InCore as I diff --git a/src/Frames/CSV.hs b/src/Frames/CSV.hs --- a/src/Frames/CSV.hs +++ b/src/Frames/CSV.hs @@ -1,27 +1,40 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, - LambdaCase, OverloadedStrings, RankNTypes, - ScopedTypeVariables, TemplateHaskell, TypeApplications, - TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# 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) + +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 import Data.Proxy 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 @@ -32,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)) +import System.IO (Handle, IOMode (ReadMode, WriteMode), hPrint, stderr) -- * Parsing @@ -45,30 +58,37 @@ 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) - -data ParserOptions = ParserOptions { headerOverride :: Maybe [T.Text] - , columnSeparator :: Separator - , quotingMode :: QuotingMode } - deriving (Eq, Show) + = -- | 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) -instance Lift QuotingMode where - lift NoQuoting = [|NoQuoting|] - lift (RFC4180Quoting char) = [|RFC4180Quoting $(litE . charL $ char)|] +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 +#else + liftTyped = unsafeTExpCoerce . lift +#endif +#endif -- | Default 'ParseOptions' get column names from a header line, and -- use commas to separate columns. @@ -82,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" @@ -139,127 +161,181 @@ -- | Infer column types from a prefix (up to 1000 lines) of a CSV -- file. -prefixInference :: (ColumnTypeable a, Monoid a, Monad m) - => ParserOptions - -> P.Parser T.Text m [a] -prefixInference opts = P.draw >>= \case - Nothing -> return [] - Just row1 -> P.foldAll (\ts -> zipWith (<>) ts . inferCols) - (inferCols row1) - id - where inferCols = map inferType . tokenizeRow opts +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 ((tokenizeRow opts - . fromMaybe (error "Empty Producer has no header row")) <$> P.draw) - pure - (headerOverride opts) - colTypes <- prefixInference opts - return (zip headerRow colTypes) + 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 fp sep = produceTextLines fp >-> P.map tokenize + 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 = pipeLines (try . fmap T.decodeLatin1 . B8.hGetLine) +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 = - produceTextLines csvFile >-> pipeTableMaybeOpt opts -{-# INLINE readTableMaybeOpt #-} + 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) . readRow opts) -{-# INLINE pipeTableMaybeOpt #-} + 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) -{-# INLINE pipeTableEitherOpt #-} + 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 -{-# INLINE readTableMaybe #-} -- | 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 -{-# INLINE pipeTableMaybe #-} -- | 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 -{-# INLINE pipeTableEither #-} -- -- | Returns a `MonadPlus` producer of rows for which each column was -- -- successfully parsed. This is typically slower than 'readTableOpt'. @@ -276,82 +352,179 @@ -- False -> let r = recMaybe . readRow opts <$> T.hGetLine h -- in liftIO r >>= maybe go (flip mplus go . return) -- go --- {-# INLINE readTableOpt' #-} -- -- | Returns a `MonadPlus` producer of rows for which each column was -- -- successfully parsed. This is typically slower than 'readTable'. -- readTable' :: forall m rs. (P.MonadSafe m, ReadRec rs) -- => FilePath -> m (Record rs) -- readTable' = readTableOpt' defaultParser --- {-# INLINE readTable' #-} -- | 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 -{-# INLINE readTableOpt #-} + 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 -{-# INLINE pipeTableOpt #-} -- | 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 -{-# INLINE readTable #-} +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 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) + -- | 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 -{-# INLINE pipeTable #-} -- * 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 recs = do - P.yield (intercalate "," (columnHeaders (Proxy :: Proxy (Record ts)))) - F.mapM_ (P.yield . T.unpack . T.intercalate "," . showFieldsCSV) recs +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 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 + 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 Show 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 "," . map T.pack . showFields) + 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 fp recs = P.runSafeT . P.runEffect $ - produceCSV recs >-> P.map T.pack >-> consumeTextLines fp +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 diff --git a/src/Frames/Categorical.hs b/src/Frames/Categorical.hs --- a/src/Frames/Categorical.hs +++ b/src/Frames/Categorical.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, MagicHash, +{-# LANGUAGE CPP, DataKinds, KindSignatures, MagicHash, ScopedTypeVariables, TemplateHaskell, TypeFamilies, ViewPatterns #-} -- | Support for representing so-called categorical variables: a @@ -24,6 +24,7 @@ import Frames.ColumnTypeable import Frames.InCore (VectorFor) import Frames.ShowCSV +import Frames.Utils import GHC.Exts (Proxy#, proxy#) import GHC.TypeNats import Language.Haskell.TH @@ -67,15 +68,19 @@ ([ dataDecl, iIsString, iReadable, iParseable , iShowCSV, iVectorFor, iNFData ] ++) <$> unboxDecls name (length variants) - where variantCons = map (mkName . maybe id (++) prefix . cap) variants + where variantCons = map (mkName . T.unpack . sanitizeTypeName . T.pack . maybe id (++) prefix . cap) variants onVariants :: (String -> Name -> a) -> [a] onVariants f = getZipList (f <$> ZipList variants <*> ZipList variantCons) - nameName = mkName name + nameName = mkName . T.unpack . sanitizeTypeName . T.pack $ name fromStringClause variant variantCon = Clause [LitP (StringL variant)] (NormalB (ConE variantCon)) [] showCSVClause variant variantCon = +#if MIN_VERSION_template_haskell(2,18,0) + Clause [ConP variantCon [] []] +#else Clause [ConP variantCon []] +#endif (NormalB (AppE (VarE 'T.pack) (LitE (StringL variant)))) [] readableGuarded :: Name -> String -> Name -> (Guard, Exp) @@ -108,7 +113,11 @@ InstanceD Nothing [] (AppT (ConT ''ShowCSV) (ConT nameName)) [FunD 'showCSV (onVariants showCSVClause)] iVectorFor = +#if __GLASGOW_HASKELL__ >= 808 + TySynInstD (TySynEqn Nothing (AppT (ConT ''VectorFor) (ConT nameName)) (ConT ''VU.Vector)) +#else TySynInstD ''VectorFor (TySynEqn [ConT nameName] (ConT ''VU.Vector)) +#endif iNFData = let argName = mkName "x" in InstanceD Nothing [] (AppT (ConT ''NFData) (ConT nameName)) diff --git a/src/Frames/ColumnTypeable.hs b/src/Frames/ColumnTypeable.hs --- a/src/Frames/ColumnTypeable.hs +++ b/src/Frames/ColumnTypeable.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase, - ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures, ScopedTypeVariables #-} module Frames.ColumnTypeable where import Control.Monad (MonadPlus) import Data.Maybe (fromMaybe) import Data.Readable (Readable(fromText)) import Data.Typeable (Proxy(..), typeRep, Typeable) import qualified Data.Text as T +import Data.Int (Int32, Int64) import Data.Vinyl.Functor (Const(..)) import Language.Haskell.TH @@ -58,10 +58,21 @@ parse' :: (MonadPlus m, Parseable a) => T.Text -> m a parse' = fmap discardConfidence . parse +parseIntish :: (Readable a, MonadPlus f) => T.Text -> f (Parsed a) +parseIntish t = + Definitely <$> fromText (fromMaybe t (T.stripSuffix (T.pack ".0") t)) + instance Parseable Bool where + instance Parseable Int where - parse t = Definitely <$> - fromText (fromMaybe t (T.stripSuffix (T.pack ".0") t)) + parse = parseIntish +instance Parseable Int32 where + parse = parseIntish +instance Parseable Int64 where + parse = parseIntish +instance Parseable Integer where + parse = parseIntish + instance Parseable Float where instance Parseable Double where -- Some CSV's export Doubles in a format like '1,000.00', filtering diff --git a/src/Frames/ColumnUniverse.hs b/src/Frames/ColumnUniverse.hs --- a/src/Frames/ColumnUniverse.hs +++ b/src/Frames/ColumnUniverse.hs @@ -1,164 +1,232 @@ -{-# 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)) - mappend x y = x <> y +-- 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) => Show (CoRec ColInfo ts) where show x = "(Col " ++ onCoRec @Show show x ++")" +#endif -- * Common Columns @@ -172,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 --- for an example of --- extending the default types with your own. +-- column types that @Frames@ can infer. See the +-- for an example of +-- extending the default types with your own. type Columns = ColumnUniverse CommonColumns diff --git a/src/Frames/Exploration.hs b/src/Frames/Exploration.hs --- a/src/Frames/Exploration.hs +++ b/src/Frames/Exploration.hs @@ -10,19 +10,26 @@ -- | Functions useful for interactively exploring and experimenting -- with a data set. module Frames.Exploration (pipePreview, select, lenses, recToList, - pr, pr1) where + pr, pr1, showFrame, printFrame, + takeRows, dropRows) where import Data.Char (isSpace, isUpper) +import qualified Data.Foldable as F +import Data.Kind (Type) +import Data.List (intercalate) import Data.Proxy import qualified Data.Vinyl as V import qualified Data.Vinyl.Class.Method as V import Data.Vinyl.Functor (ElField(Field), Const(..)) import Frames.Rec import GHC.TypeLits (Symbol) -import Language.Haskell.TH +import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Quote import Pipes hiding (Proxy) +import qualified Pipes as P import qualified Pipes.Prelude as P import Pipes.Safe (SafeT, runSafeT, MonadMask) +import Frames.Frame (Frame(Frame)) +import Frames.RecF (columnHeaders, ColumnHeaders) -- * Preview Results @@ -86,11 +93,11 @@ -- * ToList -recToList :: forall a (rs :: [(Symbol,*)]). +recToList :: forall a (rs :: [(Symbol, Type)]). (V.RecMapMethod ((~) a) ElField rs, V.RecordToList rs) => Record rs -> [a] recToList = V.recordToList . V.rmapMethod @((~) a) aux - where aux :: a ~ (V.PayloadType ElField t) => V.ElField t -> Const a t + where aux :: a ~ V.PayloadType ElField t => V.ElField t -> Const a t aux (Field x) = Const x -- * Helpers @@ -107,3 +114,34 @@ -- | Remove white space from both ends of a 'String'. strip :: String -> String strip = takeWhile (not . isSpace) . dropWhile isSpace + +-- | @takeRows n frame@ produces a new 'Frame' made up of the first +-- @n@ rows of @frame@. +takeRows :: Int -> Frame (Record rs) -> Frame (Record rs) +takeRows n (Frame len rows) = Frame (min n len) rows + +-- | @dropRows n frame@ produces a new 'Frame' just like @frame@, but +-- not including its first @n@ rows. +dropRows :: Int -> Frame (Record rs) -> Frame (Record rs) +dropRows n (Frame len rows) = Frame (max 0 (len - n)) (\i -> rows (i + n)) + +-- | Format a 'Frame' to a 'String'. +showFrame :: forall rs. + (ColumnHeaders rs, V.RecMapMethod Show ElField rs, V.RecordToList rs) + => String -- ^ Separator between fields + -> Frame (Record rs) -- ^ The 'Frame' to be formatted to a 'String' + -> String +showFrame sep frame = + unlines (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs))) : rows) + where rows = P.toList (F.mapM_ (P.yield . intercalate sep . showFields) frame) + +-- | Print a 'Frame' to 'System.IO.stdout'. +printFrame :: forall rs. + (ColumnHeaders rs, V.RecMapMethod Show ElField rs, V.RecordToList rs) + => String -- ^ Separator between fields + -> Frame (Record rs) -- ^ The 'Frame' to be printed to @stdout@ + -> IO () +printFrame sep frame = do + putStrLn (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs)))) + P.runEffect (rows >-> P.stdoutLn) + where rows = F.mapM_ (P.yield . intercalate sep . showFields) frame diff --git a/src/Frames/ExtraInstances.hs b/src/Frames/ExtraInstances.hs --- a/src/Frames/ExtraInstances.hs +++ b/src/Frames/ExtraInstances.hs @@ -49,8 +49,11 @@ instance NFData1 VF.Identity where liftRnf r = r . getIdentity +#if MIN_VERSION_vinyl(0,13,1) +#else instance (NFData (f r), NFData (Rec f rs)) => NFData (Rec f (r ': rs)) where rnf (x :& xs) = rnf x `seq` rnf xs +#endif instance NFData (Rec f '[]) where rnf RNil = () diff --git a/src/Frames/Frame.hs b/src/Frames/Frame.hs --- a/src/Frames/Frame.hs +++ b/src/Frames/Frame.hs @@ -29,14 +29,13 @@ instance Eq r => Eq (Frame r) where Frame l1 r1 == Frame l2 r2 = - l1 == l2 && and (map (\i -> r1 i == r2 i) [0 .. l1 - 1]) + l1 == l2 && all (\i -> r1 i == r2 i) [0 .. l1 - 1] -- | The 'Monoid' instance for 'Frame' provides a mechanism for -- vertical concatenation of 'Frame's. That is, @f1 <> f2@ will return -- a new 'Frame' with the rows of @f1@ followed by the rows of @f2@. instance Monoid (Frame r) where mempty = Frame 0 (const $ error "index out of bounds (empty frame)") - f1 `mappend` f2 = f1 <> f2 instance Semigroup (Frame r) where Frame l1 f1 <> Frame l2 f2 = diff --git a/src/Frames/InCore.hs b/src/Frames/InCore.hs --- a/src/Frames/InCore.hs +++ b/src/Frames/InCore.hs @@ -1,18 +1,12 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE BangPatterns, - CPP, - DataKinds, - EmptyCase, - FlexibleInstances, - ScopedTypeVariables, - TupleSections, - TypeFamilies, - TypeOperators, - UndecidableInstances #-} +{-# LANGUAGE BangPatterns, CPP, DataKinds, EmptyCase, + FlexibleContexts, FlexibleInstances, PolyKinds, + ScopedTypeVariables, TupleSections, TypeFamilies, + TypeOperators, UndecidableInstances #-} -- | Efficient in-memory (in-core) storage of tabular data. module Frames.InCore where import Control.Monad.Primitive import Control.Monad.ST (runST) +import Data.Kind (Type) import Data.Proxy import Data.Text (Text) import qualified Data.Vector as VB @@ -30,12 +24,12 @@ import GHC.Prim (RealWorld) #endif import GHC.TypeLits (KnownSymbol) -import GHC.Types (Symbol, Type) +import GHC.Types (Symbol) import qualified Pipes as P import qualified Pipes.Prelude as P -- | The most efficient vector type for each column data type. -type family VectorFor t :: * -> * +type family VectorFor t :: Type -> Type type instance VectorFor Bool = VU.Vector type instance VectorFor Int = VU.Vector type instance VectorFor Float = VU.Vector @@ -156,7 +150,8 @@ -- which provides an easier-to-use function that indexes into the -- table in a row-major fashion. inCoreSoA :: forall m rs. (PrimMonad m, RecVec rs) - => P.Producer (Record rs) m () -> m (Int, V.Rec (((->) Int) :. ElField) rs) + => P.Producer (Record rs) m () + -> m (Int, V.Rec (((->) Int) :. ElField) rs) inCoreSoA xs = do mvs <- allocRec (Proxy :: Proxy rs) initialCapacity let feed (!i, !sz, !mvs') row @@ -227,3 +222,39 @@ filterFrame :: RecVec rs => (Record rs -> Bool) -> FrameRec rs -> FrameRec rs filterFrame p f = runST $ inCoreAoS $ P.each f P.>-> P.filter p {-# INLINE filterFrame #-} + +-- | Process a stream of 'Record's into a stream of 'Frame's that each +-- contains no more than the given number of records. +produceFrameChunks :: forall rs m. (RecVec rs, PrimMonad m) + => Int + -> P.Producer (Record rs) m () + -> P.Producer (FrameRec rs) m () +produceFrameChunks chunkSize = go + where go src = do mutVecs <- P.lift (allocRec (Proxy :: Proxy rs) chunkSize) + goChunk src mutVecs 0 + goChunk src mutVecs !i + | i >= chunkSize = + do chunk <- P.lift (freezeFrame i mutVecs) + P.yield chunk + go src + | otherwise = + do maybeRow <- P.lift (P.next src) + case maybeRow of + Left _ -> do + P.lift (freezeFrame i mutVecs) >>= P.yield + Right (r,src') -> do + P.lift (writeRec (Proxy::Proxy rs) i mutVecs r) + goChunk src' mutVecs (i+1) + freezeFrame :: Int -> Record (VectorMs m rs) -> m (FrameRec rs) + freezeFrame n = + fmap (toAoS n . produceRec (Proxy::Proxy rs)) + . freezeRec (Proxy::Proxy rs) n +{-# INLINABLE produceFrameChunks #-} + +-- | Split a 'Frame' into chunks of no more than the given number of +-- records. The underlying memory is shared with the original 'Frame'. +frameChunks :: Int -> FrameRec rs -> [FrameRec rs] +frameChunks chunkSize whole = map aux [ 0, chunkSize .. frameLength whole - 1 ] + where aux i = Frame (min (frameLength whole - i) chunkSize) + (frameRow whole . (+ i)) +{-# INLINABLE frameChunks #-} diff --git a/src/Frames/Rec.hs b/src/Frames/Rec.hs --- a/src/Frames/Rec.hs +++ b/src/Frames/Rec.hs @@ -68,5 +68,5 @@ -- intended for use with @OverloadedLabels@. rputField :: forall t s a rs. (t ~ '(s,a), t ∈ rs, KnownSymbol s) => a -> Record rs -> Record rs -rputField = V.rput @t . Field +rputField = V.rput @_ @t . Field {-# INLINE rputField #-} diff --git a/src/Frames/RecF.hs b/src/Frames/RecF.hs --- a/src/Frames/RecF.hs +++ b/src/Frames/RecF.hs @@ -29,6 +29,7 @@ ColFun, ColumnHeaders, columnHeaders) where -- import Data.List (intercalate) +import Data.Kind (Type) import Data.Proxy import qualified Data.Vinyl as V import Data.Vinyl (Rec(..)) @@ -70,7 +71,7 @@ -- pattern x :& xs <- (frameUncons -> (x, xs)) where -- x :& xs = frameCons x xs -class ColumnHeaders (cs::[(Symbol,*)]) where +class ColumnHeaders (cs::[(Symbol, Type)]) where -- | Return the column names for a record. columnHeaders :: proxy (Rec f cs) -> [String] @@ -88,7 +89,7 @@ -- | Strip the column information from each element of a list of -- types. -type family UnColumn (ts :: [(Symbol,*)]) where +type family UnColumn (ts :: [(Symbol, Type)]) where UnColumn '[] = '[] UnColumn ((s :-> t) ': ts) = t ': UnColumn ts diff --git a/src/Frames/ShowCSV.hs b/src/Frames/ShowCSV.hs --- a/src/Frames/ShowCSV.hs +++ b/src/Frames/ShowCSV.hs @@ -14,3 +14,4 @@ instance ShowCSV Int where instance ShowCSV Double where instance ShowCSV Text where + showCSV = id diff --git a/src/Frames/TH.hs b/src/Frames/TH.hs --- a/src/Frames/TH.hs +++ b/src/Frames/TH.hs @@ -2,16 +2,14 @@ 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. module Frames.TH where -import Control.Arrow (first, second) -import Data.Char (isAlpha, isAlphaNum, toLower, toUpper) +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 @@ -21,12 +19,14 @@ 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 +import Data.Vinyl.CoRec (ShowF) -- | Generate a column type. recDec :: [Type] -> Type @@ -34,25 +34,6 @@ where go [] = PromotedNilT go (t:cs) = AppT (AppT PromotedConsT t) (go cs) --- | Capitalize the first letter of a 'T.Text'. -capitalize1 :: T.Text -> T.Text -capitalize1 = foldMap (onHead toUpper) . T.split (not . isAlphaNum) - where onHead f = maybe mempty (uncurry T.cons . first f) . T.uncons - --- | Massage a column name from a CSV file into a valid Haskell type --- identifier. -sanitizeTypeName :: T.Text -> T.Text -sanitizeTypeName = unreserved . fixupStart - . T.concat . T.split (not . valid) . capitalize1 - where valid c = isAlphaNum c || c == '\'' || c == '_' - unreserved t - | t `elem` ["Type", "Class"] = "Col" <> t - | otherwise = t - fixupStart t = case T.uncons t of - Nothing -> "Col" - Just (c,_) | isAlpha c -> t - | otherwise -> "Col" <> t - -- | Declare a type synonym for a column. mkColSynDec :: TypeQ -> Name -> DecQ mkColSynDec colTypeQ colTName = tySynD colTName [] colTypeQ @@ -91,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 @@ -150,37 +131,46 @@ -- ^ 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. - , lineReader :: P.Producer T.Text (P.SafeT IO) () - -- ^ A producer of lines of ’T.Text’xs + , inferencePrefix :: Int + -- ^ Number of rows to inspect to infer a type for each + -- column. Defaults to 1000. + , 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))) |] +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 = RowGen [] "" defaultSep "Row" Proxy . produceTextLines +rowGen = RowGen [] "" defaultSep "Row" Proxy 1000 . produceTokens -- | Like 'rowGen', but will also generate custom data types for -- 'Categorical' variables with up to 8 distinct variants. rowGenCat :: FilePath -> RowGen CommonColumnsCat -rowGenCat = RowGen [] "" defaultSep "Row" Proxy . produceTextLines +rowGenCat = RowGen [] "" defaultSep "Row" Proxy 1000 . 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@. +-- | Generate types for a row of a table. This will be something like +-- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@. This splice +-- 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@. +-- +-- See 'tableTypes'' if you need to customize parsing to do things +-- like override the separator character (default is a single comma), +-- or supply column names. tableTypes :: String -> FilePath -> DecsQ tableTypes n fp = tableTypes' (rowGen fp) { rowTypeName = n } @@ -202,25 +192,24 @@ -- colNames' | null columnNames = Nothing -- | otherwise = Just (map T.pack columnNames) -- opts = ParserOptions colNames' separator (RFC4180Quoting '\"') --- lineSource = lineReader >-> P.take prefixSize +-- lineSource = lineReader separator >-> P.take prefixSize -- | Tokenize the first line of a ’P.Producer’. -colNamesP :: Monad m - => ParserOptions -> P.Producer T.Text m () -> m [T.Text] -colNamesP opts src = either (const []) (tokenizeRow opts . fst) <$> P.next src +colNamesP :: Monad m => P.Producer [T.Text] m () -> m [T.Text] +colNamesP src = either (const []) fst <$> P.next 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) + (c ~ CoRec ColInfo a, ColumnTypeable c, Semigroup c) => RowGen a -> DecsQ -tableTypesText' (RowGen {..}) = +tableTypesText' RowGen {..} = do colNames <- runIO . P.runSafeT $ - maybe (colNamesP opts lineReader) + maybe (colNamesP (lineReader separator)) pure (headerOverride opts) let headers = zip colNames (repeat (ConT ''T.Text)) - (colTypes, colDecs) <- (second concat . unzip) + (colTypes, colDecs) <- second concat . unzip <$> mapM (uncurry mkColDecs) headers let recTy = TySynD (mkName rowTypeName) [] (recDec colTypes) optsName = case rowTypeName of @@ -246,7 +235,15 @@ -- 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) +-- +-- The supplied 'RowGen' value is also used to produce a value of type +-- 'ParserOptions' that can be passed to functions like +-- 'readTableOpt'. This is useful if you need to customize parsing to +-- support something like a special separator string. This value of +-- type 'ParserOptions' will be given a name based on the row type +-- name. If the row type is @Row@, then thsi splice will generate a +-- value @rowParser :: ParserOptions@. +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 @@ -266,7 +263,7 @@ where colNames' | null columnNames = Nothing | otherwise = Just (map T.pack columnNames) opts = ParserOptions colNames' separator (RFC4180Quoting '\"') - lineSource = lineReader P.>-> P.take prefixSize + lineSource = lineReader separator P.>-> P.take inferencePrefix mkColDecs :: T.Text -> Either (String -> Q [Dec]) Type -> Q (Type, [Dec]) mkColDecs colNm colTy = do let safeName = tablePrefix ++ (T.unpack . sanitizeTypeName $ colNm) @@ -274,3 +271,4 @@ case mColNm of Just n -> pure (ConT n, []) -- Column's type was already defined Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm colTy + diff --git a/src/Frames/Utils.hs b/src/Frames/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Utils.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +module Frames.Utils (capitalize1, sanitizeTypeName) where + +import Control.Arrow (first) +import Data.Char (isAlpha, isAlphaNum, toUpper) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif +import qualified Data.Text as T + +-- | Capitalize the first letter of a 'T.Text'. +capitalize1 :: T.Text -> T.Text +capitalize1 = foldMap (onHead toUpper) . T.split (not . isAlphaNum) + where onHead f = maybe mempty (uncurry T.cons . first f) . T.uncons + +-- | Massage a column name from a CSV file into a valid Haskell type +-- identifier. +sanitizeTypeName :: T.Text -> T.Text +sanitizeTypeName = unreserved . fixupStart + . T.concat . T.split (not . valid) . capitalize1 + where valid c = isAlphaNum c || c == '\'' || c == '_' + unreserved t + | t `elem` ["Type", "Class"] = "Col" <> t + | otherwise = t + fixupStart t = case T.uncons t of + Nothing -> "Col" + Just (c,_) | isAlpha c -> t + | otherwise -> "Col" <> t diff --git a/test/Categorical.hs b/test/Categorical.hs --- a/test/Categorical.hs +++ b/test/Categorical.hs @@ -1,14 +1,19 @@ {-# LANGUAGE DataKinds, FlexibleContexts, MultiParamTypeClasses, - OverloadedLabels, OverloadedStrings, TemplateHaskell, - TypeFamilies, TypeOperators #-} + OverloadedLabels, OverloadedStrings, TemplateHaskell, + TypeApplications, TypeFamilies, TypeOperators #-} module Categorical where -import Data.Vinyl.Derived -import Data.Vinyl.XRec (toHKD) -import Frames -import Frames.Categorical (declareCategorical) -import Frames.TH (rowGenCat, RowGen(..), declarePrefixedColumn) -import Pipes (Producer, (>->)) -import qualified Pipes.Prelude as P +import Data.Vinyl.Derived +import Data.Vinyl.XRec ( toHKD ) +import Frames +import Frames.Categorical ( declareCategorical ) +import Frames.TH ( rowGenCat + , RowGen(..) + , declarePrefixedColumn + ) +import Pipes ( Producer + , (>->) + ) +import qualified Pipes.Prelude as P -- * Automatically inferred categorical data types @@ -19,17 +24,19 @@ -- no more than 8 variants. In our small data file, five distinct -- months appear, so a data type is generated and used. fifthMonthSmall :: IO (Maybe SmallMonth) -fifthMonthSmall = fmap (fmap (rvalf #month)) . runSafeEffect . P.head - $ load >-> P.drop 4 - where load :: MonadSafe m => Producer Small m () - load = readTableOpt smallParser "test/data/catSmall.csv" +fifthMonthSmall = + fmap (fmap (rvalf #month)) . runSafeEffect . P.head $ load >-> P.drop 4 + where + load :: MonadSafe m => Producer Small m () + load = readTableOpt smallParser "test/data/catSmall.csv" -- When every month appears, Frames leaves that column's type as 'Text'. fifthMonthLarge :: IO (Maybe Text) -fifthMonthLarge = fmap (fmap (rvalf #month)) . runSafeEffect . P.head - $ load >-> P.drop 4 - where load :: MonadSafe m => Producer Large m () - load = readTableOpt largeParser "test/data/catLarge.csv" +fifthMonthLarge = + fmap (fmap (rvalf #month)) . runSafeEffect . P.head $ load >-> P.drop 4 + where + load :: MonadSafe m => Producer Large m () + load = readTableOpt largeParser "test/data/catLarge.csv" -- * Custom categorical type @@ -51,7 +58,8 @@ -- parses. We use 'toHKD' to cut through the noise of the @(Maybe -- :. ElField)@ interpretation we parsed into. fifthMonthCustom :: IO (Maybe MyMonthData) -fifthMonthCustom = fmap (>>= toHKD . rgetf #month) . runSafeEffect . P.head - $ load >-> P.drop 4 - where load :: MonadSafe m => Producer (ColFun Maybe MyRow) m () - load = readTableMaybe "test/data/catSmall.csv" +fifthMonthCustom = + fmap (>>= toHKD . rgetf #month) . runSafeEffect . P.head $ load >-> P.drop 4 + where + load :: MonadSafe m => Producer (ColFun Maybe MyRow) m () + load = readTableMaybe "test/data/catSmall.csv" diff --git a/test/Chunks.hs b/test/Chunks.hs new file mode 100644 --- /dev/null +++ b/test/Chunks.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, + TemplateHaskell, TypeApplications #-} +module Chunks where +import Frames +import Frames.InCore (frameChunks, produceFrameChunks) +import Pipes ((>->)) +import qualified Pipes.Prelude as P + +tableTypes "Row" "test/data/prestige.csv" + +getEducation :: Row -> Double +getEducation = rgetField @Education + +chunkInCore :: IO [Double] +chunkInCore = do + rows <- inCoreAoS (readTable "test/data/prestige.csv") + let chunks = frameChunks 10 rows + return $ map (getEducation . flip frameRow 0) chunks + +chunkStream :: IO [Double] +chunkStream = runSafeT . P.toListM $ + produceFrameChunks 10 (readTable "test/data/prestige.csv") + >-> P.map (getEducation . flip frameRow 0) diff --git a/test/DataCSV.hs b/test/DataCSV.hs --- a/test/DataCSV.hs +++ b/test/DataCSV.hs @@ -1,47 +1,58 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + module DataCSV where -import Control.Monad ((>=>)) + import Data.Bifunctor (first) -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 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 } +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)) - <$> T.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 diff --git a/test/Issue114.hs b/test/Issue114.hs --- a/test/Issue114.hs +++ b/test/Issue114.hs @@ -5,23 +5,27 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Issue114 where import Frames -import qualified Control.Foldl as Foldl +import qualified Control.Foldl as Foldl import Control.Lens -import Pipes.Prelude (fold) +import Pipes.Prelude ( fold ) import Pipes -import qualified Pipes.Prelude as P -import qualified Pipes.Core as PC +import qualified Pipes.Prelude as P +import qualified Pipes.Core as PC -import qualified Data.Vinyl as V -import Data.Vinyl (Rec(..)) +import qualified Data.Vinyl as V +import Data.Vinyl ( Rec(..) ) -import qualified Data.Text as T +import qualified Data.Text as T import Data.Attoparsec.Text import Control.Applicative -import Frames.TH (tableTypesText', rowGen, RowGen(..)) +import Frames.TH ( tableTypesText' + , rowGen + , RowGen(..) + ) tableTypesText' (rowGen "test/data/issue114.csv") { rowTypeName = "ProductionData" } @@ -29,13 +33,12 @@ getOilVol :: ProductionData -> Record '[OilVolDouble] getOilVol x = V.Field (f (parseOnly parseDouble (x ^. oilVol))) :& RNil - where - f (Left _) = 0.0 / 0.0 - f (Right y) = y + where + f (Left _) = 0.0 / 0.0 + f (Right y) = y readOilVol :: MonadSafe m => Producer (Record '[OilVolDouble]) m () -readOilVol = (readTable "test/data/issue114.csv") >-> - (P.map getOilVol) +readOilVol = (readTable "test/data/issue114.csv") >-> (P.map getOilVol) oilVolLength :: Foldl.Fold (Record '[OilVolDouble]) Int oilVolLength = Foldl.length @@ -48,16 +51,16 @@ parseDouble :: Parser Double parseDouble = - do d <- double - return d - <|> - do _ <- string "" - return 0.0 + do + d <- double + return d + <|> do + _ <- string "" + return 0.0 test :: IO () test = do - (t, l) <- runSafeT $ - Foldl.purely fold oilVolTotalAndLength readOilVol + (t, l) <- runSafeT $ Foldl.purely fold oilVolTotalAndLength readOilVol putStrLn $ show l ++ " records totalling " ++ show t loadTable :: MonadSafe m => PC.Producer ProductionData m () diff --git a/test/Issue145.hs b/test/Issue145.hs new file mode 100644 --- /dev/null +++ b/test/Issue145.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Issue145 where + +import Frames.TH (RowGen (..), rowGenCat, tableTypes') + +tableTypes' (rowGenCat "test/data/issue145.csv") { rowTypeName = "Row", tablePrefix = "C" } diff --git a/test/LatinTest.hs b/test/LatinTest.hs --- a/test/LatinTest.hs +++ b/test/LatinTest.hs @@ -10,9 +10,8 @@ module LatinTest where -import Data.Vinyl (Rec) import Frames -import Frames.CSV (pipeTableMaybe, readFileLatin1Ln) +import Frames.CSV (readFileLatin1Ln) import Pipes (Producer, (>->)) import qualified Pipes.Prelude as P diff --git a/test/NoHeader.hs b/test/NoHeader.hs --- a/test/NoHeader.hs +++ b/test/NoHeader.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedLabels, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedLabels, TemplateHaskell, TypeApplications #-} module NoHeader where -import Control.Arrow ((&&&)) -import Data.Vinyl.Derived -import Frames -import Frames.TH (rowGen, RowGen(..)) -import Pipes (Producer, (>->)) -import qualified Pipes.Prelude as P +import Control.Arrow ( (&&&) ) +import Data.Vinyl.Derived +import Frames +import Frames.TH ( rowGen + , RowGen(..) + ) +import Pipes ( Producer + , (>->) + ) +import qualified Pipes.Prelude as P tableTypes' (rowGen "test/data/prestigeNoHeader.csv") { rowTypeName = "Row" @@ -22,7 +26,8 @@ -- | Extract the @Job@ and @Schooling@ columns of the indicated row. getJobAndSchooling :: Int -> IO (Maybe (Text, Double)) -getJobAndSchooling n = fmap (fmap aux) . runSafeEffect . P.head - $ loadData >-> P.drop (max n 0) - where aux :: Row -> (Text, Double) - aux = rvalf #job &&& rvalf #schooling +getJobAndSchooling n = + fmap (fmap aux) . runSafeEffect . P.head $ loadData >-> P.drop (max n 0) + where + aux :: Row -> (Text, Double) + aux = rvalf #job &&& rvalf #schooling diff --git a/test/Overlap.hs b/test/Overlap.hs --- a/test/Overlap.hs +++ b/test/Overlap.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-} -module Main (main) where -import Frames +{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell, TypeApplications #-} +module Main + ( main + ) +where +import Frames -- These data files have overlapping column definitions. Frames should -- not try to re-define an existing identifier. diff --git a/test/PrettyTH.hs b/test/PrettyTH.hs --- a/test/PrettyTH.hs +++ b/test/PrettyTH.hs @@ -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." "" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,17 +1,21 @@ {-# LANGUAGE CPP, DataKinds, OverloadedStrings, QuasiQuotes, - TemplateHaskell, TypeOperators #-} + ScopedTypeVariables, TemplateHaskell, TypeApplications, + TypeOperators #-} module Main (manualGeneration, main) where +import Control.Exception (ErrorCall, catch) import Control.Monad (unless) import Data.Functor.Identity import Data.Char import qualified Data.Foldable as F -import Data.List (find) +import Data.List (find, isPrefixOf) import Data.Monoid (First(..)) import qualified Data.Text as T -import Language.Haskell.TH as TH +import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (addDependentFile) import Frames import Frames.CSV (produceCSV) +import Frames.CSV (defaultParser, produceTokens, defaultSep, readColHeaders) +import qualified Chunks import DataCSV import Pipes.Prelude (toListM) import PrettyTH @@ -21,22 +25,24 @@ import Test.HUnit.Lang (assertFailure) import qualified LatinTest as Latin -import qualified Issue114 as Issue114 +import qualified Issue114 +import qualified Issue145 import qualified NoHeader import qualified Categorical import qualified UncurryFold import qualified UncurryFoldNoHeader import qualified UncurryFoldPartialData +import Data.Vinyl (xrec) -- | Extract all example @(CSV, generatedCode)@ pairs from -- @test/examples.toml@ csvTests :: [(CsvExample, String)] csvTests = $(do addDependentFile "test/examples.toml" csvExamples <- TH.runIO (examplesFrom "test/examples.toml") - ListE <$> mapM (\x@(CsvExample _ c _) -> - [e|(x,$(generateCode "Row" c))|]) - csvExamples) + TH.ListE <$> mapM (\x@(CsvExample _ c _) -> + [e|(x,$(generateCode "Row" c))|]) + csvExamples) -- | Detect type-compatible re-used names and do not attempt to -- re-generate definitions for them. This does not do the right thing @@ -62,7 +68,7 @@ -- -- Note that to load this file into a REPL may require some fiddling -- with the path to the examples file in the 'csvTests' splice above. -manualGeneration :: String -> Q Exp +manualGeneration :: String -> TH.Q TH.Exp manualGeneration k = do csvExamples <- TH.runIO (examplesFrom "test/examples.toml") maybe (error ("Table " ++ k ++ " not found")) (generateCode "Row") @@ -78,7 +84,16 @@ newtype Code = Code String instance Show Code where show (Code x) = x instance Eq Code where - Code a == Code b = filter (not . isSpace) a == filter (not . isSpace) b + Code a == Code b = clean a == clean b + where clean = go (removePrefix moduleNames) . filter (not . isSpace) + go _ [] = [] + go f s@(c:cs) = case removePrefix moduleNames s of + Nothing -> c : go f cs + Just n -> go f (drop n s) + moduleNames = [ "GHC.Maybe." ] + removePrefix [] _ = Nothing + removePrefix (w:ws) s | w `isPrefixOf` s = Just (length w) + | otherwise = removePrefix ws s shouldBeWithinEpsilon :: Double -> Double -> Expectation shouldBeWithinEpsilon actual expected = @@ -92,10 +107,10 @@ main = do hspec $ do -#if __GLASGOW_HASKELL__ >= 804 + describe "Haskell type generation" $ mapM_ (\(CsvExample k _ g, g') -> it k (Code g' `shouldBe` Code g)) csvTests -#endif + -- describe "Multiple tables" $ -- do _g <- H.runIO $ -- generatedFrom "test/examples.toml" "managers_employees" @@ -119,17 +134,18 @@ -- The test data isn't formatted quite how we'd do it: text -- fields aren't quoted, and salaries represented as Doubles -- do not have decimal points. - let csvInput' = T.replace "Joe" "\"Joe\"" - . T.replace "Sarah" "\"Sarah\"" - . T.replace "\"80,000\"" "80000.0" - $ T.pack csvInput + -- let csvInput' = T.replace "Joe" "\"Joe\"" + -- . T.replace "Sarah" "\"Sarah\"" + -- . T.replace "\"80,000\"" "80000.0" + -- $ T.pack csvInput + let csvInput' = T.replace "\"80,000\"" "80000.0" (T.pack csvInput) it "Produces expected output" $ T.unlines (map T.pack csvOutput) `shouldBe` csvInput' it "Produces parseable output" $ unless (frame == frame2) (assertFailure "Reparsed CSV differs from input") describe "Latin1 Text Encoding" $ - do managers <- H.runIO (Latin.managers) + do managers <- H.runIO Latin.managers it "Parses" $ managers `shouldBe` ["João", "Esperança"] describe "Skip Missing Data" $ do @@ -189,3 +205,45 @@ mCustom <- H.runIO Categorical.fifthMonthCustom it "Can parse into manually-specified categorical variables" $ mCustom `shouldBe` Just Categorical.MyMay + it "Can generate categorical types with space" $ + enumFrom (minBound :: Issue145.RowCategoryName) + `shouldBe` [ Issue145.RowCategoryNameBarCategory + , Issue145.RowCategoryNameFooCategory] + describe "Detects parse failures" $ do + caught <- H.runIO $ + (runSafeT $ do + _ <- readColHeaders @Columns + defaultParser + (produceTokens "test/data/multiline.csv" defaultSep) + return False) + `catch` \(_ :: ErrorCall) -> return True + it "Fails on embedded newlines" caught + describe "Chunking" $ do + let everyTenthEducation = [13.11,12.39,15.97,12.79,12.09,11.13,8.5,7.64,8.78,6.92,10.0] + inCoreChunks <- H.runIO Chunks.chunkInCore + it "Can split in-memory data into chunks" $ + inCoreChunks `shouldBe` everyTenthEducation + streamedChunks <- H.runIO Chunks.chunkStream + it "Can split an input stream into Frame chunks" $ + streamedChunks `shouldBe` everyTenthEducation + describe "Printing with take and drop" $ do + let frame :: Frame (Record '[ "id" :-> Int, "manager" :-> Text + , "age" :-> Int, "pay" :-> Double ]) + frame = toFrame [ xrec (1, "Joe", 53, 80000) + , xrec (2, "Sarah", 44, 80000) ] + it "Can format a Frame to a String" $ + showFrame "\t" frame `shouldBe` + unlines [ + "id\tmanager\tage\tpay" + , "1\t\"Joe\"\t53\t80000.0" + , "2\t\"Sarah\"\t44\t80000.0" ] + it "Can take the first row" $ + showFrame "\t" (takeRows 1 frame) `shouldBe` + unlines [ + "id\tmanager\tage\tpay" + , "1\t\"Joe\"\t53\t80000.0" ] + it "Can drop the first row" $ + showFrame "\t" (dropRows 1 frame) `shouldBe` + unlines [ + "id\tmanager\tage\tpay" + , "2\t\"Sarah\"\t44\t80000.0" ] diff --git a/test/UncurryFold.hs b/test/UncurryFold.hs --- a/test/UncurryFold.hs +++ b/test/UncurryFold.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell, TypeApplications #-} module UncurryFold where -import qualified Control.Foldl as L -import Data.Vinyl (rcast) -import Data.Vinyl.Curry (runcurryX) -import Frames +import qualified Control.Foldl as L +import Data.Vinyl.Curry ( runcurryX ) +import Frames -- Data set from http://vincentarelbundock.github.io/Rdatasets/datasets.html tableTypes "Row" "test/data/prestige.csv" diff --git a/test/UncurryFoldNoHeader.hs b/test/UncurryFoldNoHeader.hs --- a/test/UncurryFoldNoHeader.hs +++ b/test/UncurryFoldNoHeader.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE DataKinds, FlexibleContexts, QuasiQuotes, TemplateHaskell, TypeApplications #-} module UncurryFoldNoHeader where -import qualified Control.Foldl as L -import Data.Vinyl (rcast) -import Data.Vinyl.Curry (runcurryX) -import Frames -import Frames.TH (rowGen, RowGen(..)) +import qualified Control.Foldl as L +import Data.Vinyl.Curry ( runcurryX ) +import Frames +import Frames.TH ( rowGen + , RowGen(..) + ) -- Data set from http://vincentarelbundock.github.io/Rdatasets/datasets.html tableTypes' (rowGen "test/data/prestigeNoHeader.csv") diff --git a/test/data/issue145.csv b/test/data/issue145.csv new file mode 100644 --- /dev/null +++ b/test/data/issue145.csv @@ -0,0 +1,3 @@ +id,category name +1,foo category +2,bar category diff --git a/test/data/multiline.csv b/test/data/multiline.csv new file mode 100644 --- /dev/null +++ b/test/data/multiline.csv @@ -0,0 +1,8 @@ +RowNum,Description,X,Y +1,"simple",10,10 +2,"""quoted""",20,20 +3,"multi +line +text +field",30,30 +4,"simple again",40,40 diff --git a/test/examples.toml b/test/examples.toml --- a/test/examples.toml +++ b/test/examples.toml @@ -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 = """